Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch unchained Through [72e1cbdd56] Excluding Merge-Ins
This is equivalent to a diff from 8d9bc901e3 to 72e1cbdd56
|
2024-09-14
| ||
| 12:24 | Add generci/tclDate.h. check-in: 5d0a381167 user: pooryorick tags: unchained, INCOMPATIBLE_LICENSE | |
| 12:16 | Merge [8d9bc901e37c4f27]: 3th "load" argument should be Titlecase Fix registry library name for Tcl ... check-in: 72e1cbdd56 user: pooryorick tags: unchained, INCOMPATIBLE_LICENSE | |
| 12:14 | Further fix to fossil tracking to that merging clock.tcl from trunk affects clock.tcl, not clockclas... check-in: 045cc4e183 user: pooryorick tags: unchained, INCOMPATIBLE_LICENSE | |
|
2024-09-11
| ||
| 06:31 | Add tcl::idna, expr operators, oo to changes.md check-in: 52a5f4ab95 user: apnadkarni tags: trunk, main | |
|
2024-09-10
| ||
| 19:58 | 3th "load" argument should be Titlecase Fix registry library name for Tcl 9 check-in: 8d9bc901e3 user: jan.nijtmans tags: trunk, main | |
| 19:48 | 3th "load" argument should be Titlecase check-in: e75679b59a user: jan.nijtmans tags: core-8-branch | |
| 13:27 | merge 8.7 check-in: a4c3f6a3e8 user: dgp tags: trunk, main | |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist | < < | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.txt |
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
jobs:
gcc:
runs-on: ubuntu-22.04
strategy:
matrix:
config:
- ""
| < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
jobs:
gcc:
runs-on: ubuntu-22.04
strategy:
matrix:
config:
- ""
- "--disable-shared"
- "--disable-zipfs"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
- "CFLAGS=-ftrapv"
# Duplicated below
|
| ︙ | ︙ |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
run:
shell: msys2 {0}
working-directory: win
strategy:
matrix:
config:
- ""
| < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
run:
shell: msys2 {0}
working-directory: win
strategy:
matrix:
config:
- ""
- "--disable-shared"
- "--disable-zipfs"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
# Using powershell means we need to explicitly stop on failure
steps:
|
| ︙ | ︙ |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex | < < | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmakehlp.out win/nmhlp-out.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 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 |
GNU AFFERO GENERAL PUBLIC LICENSE
Version 3, 19 November 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU Affero General Public License is a free, copyleft license for
software and other kinds of works, specifically designed to ensure
cooperation with the community in the case of network server software.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
our General Public Licenses are intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
Developers that use our General Public Licenses protect your rights
with two steps: (1) assert copyright on the software, and (2) offer
you this License which gives you legal permission to copy, distribute
and/or modify the software.
A secondary benefit of defending all users' freedom is that
improvements made in alternate versions of the program, if they
receive widespread use, become available for other developers to
incorporate. Many developers of free software are heartened and
encouraged by the resulting cooperation. However, in the case of
software used on network servers, this result may fail to come about.
The GNU General Public License permits making a modified version and
letting the public access it on a server without ever releasing its
source code to the public.
The GNU Affero General Public License is designed specifically to
ensure that, in such cases, the modified source code becomes available
to the community. It requires the operator of a network server to
provide the source code of the modified version running there to the
users of that server. Therefore, public use of a modified version, on
a publicly accessible server, gives the public access to the source
code of the modified version.
An older license, called the Affero General Public License and
published by Affero, was designed to accomplish similar goals. This is
a different license, not a version of the Affero GPL, but Affero has
released a new version of the Affero GPL which permits relicensing under
this license.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU Affero General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Remote Network Interaction; Use with the GNU General Public License.
Notwithstanding any other provision of this License, if you modify the
Program, your modified version must prominently offer all users
interacting with it remotely through a computer network (if your version
supports such interaction) an opportunity to receive the Corresponding
Source of your version by providing access to the Corresponding Source
from a network server at no charge, through some standard or customary
means of facilitating copying of software. This Corresponding Source
shall include the Corresponding Source for any work covered by version 3
of the GNU General Public License that is incorporated pursuant to the
following paragraph.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the work with which it is combined will remain governed by version
3 of the GNU General Public License.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU Affero General Public License from time to time. Such new versions
will be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU Affero General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU Affero General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU Affero General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper mail.
If your software can interact with users remotely through a computer
network, you should also make sure that it provides a way for users to
get its source. For example, if your program is a web application, its
interface could display a "Source" link that leads users to an archive
of the code. There are many ways you could offer source, and different
solutions will be better for different programs; see section 13 for the
specific requirements.
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU AGPL, see
<https://www.gnu.org/licenses/>.
|
1 | /* | < < < < < < > > > > > > > > > > > > > > > | 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 | /* * This file is subject to the following copyright notice, which is * different from the notice used elsewhere in Tcl but rougly * equivalent in meaning. * * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH * Not derived from licensed software. * * Permission is granted to freely use, copy, modify, and redistribute * this software, provided that the author is not construed to be liable * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * dlfcn.h -- * * This file provides a replacement for the header file "dlfcn.h" * on systems where dlfcn.h is missing. It's primary use is for * AIX, where Tcl emulates the dl library. * * 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 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. | > > > > > > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. |
| ︙ | ︙ |
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. | > > > > > > > > > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Pseudo-implementation of RFC2553 name / address resolution functions * * But these functions are not implemented correctly. The minimum subset * is implemented for ssh use only. For example, this routine assumes * that ai_family is AF_INET. Don't use it for another purpose. |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * gettod.c -- * * This file provides the gettimeofday function on systems * that only have the System V ftime function. * */ #include "tclPort.h" #include <sys/timeb.h> #undef timezone int |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * mkstemp.c -- * * Source code for the "mkstemp" library routine. * * Copyright (c) 2009 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <errno.h> #include <fcntl.h> #include <stdlib.h> #include <unistd.h> #include <string.h> | > > > > > > > > > | 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 | /* * mkstemp.c -- * * Source code for the "mkstemp" library routine. * * Copyright (c) 2009 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <errno.h> #include <fcntl.h> #include <stdlib.h> #include <unistd.h> #include <string.h> |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-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. */ #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. | > > > > > > > > > | 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 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" 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. |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * strncasecmp.c -- * * Source code for the "strncasecmp" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * 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. */ #include "tclPort.h" /* * This array is designed for mapping upper and lower case letter together for * a case independent comparison. The mappings are based upon ASCII character * sequences. | > > > > > > > > > | 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 | /* * strncasecmp.c -- * * Source code for the "strncasecmp" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" /* * This array is designed for mapping upper and lower case letter together for * a case independent comparison. The mappings are based upon ASCII character * sequences. |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * waitpid.c -- * * This procedure emulates the POSIX waitpid kernel call on BSD systems * that don't have waitpid but do have wait3. This code is based on a * prototype version written by Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" #ifndef pid_t #define pid_t int #endif | > > > > > > > > > | 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 | /* * waitpid.c -- * * This procedure emulates the POSIX waitpid kernel call on BSD systems * that don't have waitpid but do have wait3. This code is based on a * prototype version written by Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" #ifndef pid_t #define pid_t int #endif |
| ︙ | ︙ |
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes .SH SYNOPSIS | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1989-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. '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1989-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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Alloc 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Alloc 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, Tcl_GetMemoryInfo \- allocate or free heap memory .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" 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. '\" .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation .SH SYNOPSIS | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AppInit \- perform application-specific initialization .SH SYNOPSIS | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_AppInit \- perform application-specific initialization .SH SYNOPSIS |
| ︙ | ︙ |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last block in a (potentially multi-block) input stream, telling the conversion routine to perform any finalization that needs to occur after the last byte is converted and then to reset to an initial state. The \fBTCL_PROFILE_*\fR bits defined in the \fBPROFILES\fR section below control the encoding profile to be used for dealing with invalid data or other errors in the encoding transform. | < < < | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | converted. \fBTCL_ENCODING_END\fR signifies that the source buffer is the last block in a (potentially multi-block) input stream, telling the conversion routine to perform any finalization that needs to occur after the last byte is converted and then to reset to an initial state. The \fBTCL_PROFILE_*\fR bits defined in the \fBPROFILES\fR section below control the encoding profile to be used for dealing with invalid data or other errors in the encoding transform. Some flags bits may not be usable with some functions as noted in the function descriptions below. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current state in \fI*statePtr\fR after \fIsrc\fR (the buffer containing the current piece) has been converted; that state information must be passed |
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
.PP
.CS
.ta 1.5i
# Encoding file: iso2022-jp, escape-driven
E
init {}
final {}
| | | | | | | | | | 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 |
.PP
.CS
.ta 1.5i
# Encoding file: iso2022-jp, escape-driven
E
init {}
final {}
iso8859-1 \ex1b(B
jis0201 \ex1b(J
jis0208 \ex1b$@
jis0208 \ex1b$B
jis0212 \ex1b$(D
gb2312 \ex1b$A
ksc5601 \ex1b$(C
.CE
.PP
In the file, the first column represents an option and the second column
is the associated value. \fBinit\fR is a string to emit or expect before
the first character is converted, while \fBfinal\fR is a string to emit
or expect after the last character. All other options are names of
table-based encodings; the associated value is the escape-sequence that
marks that encoding. Tcl syntax is used for the values; in the above
example, for instance,
.QW \fB{}\fR
represents the empty string and
.QW \fB\ex1b\fR
represents character 27.
.PP
When \fBTcl_GetEncoding\fR encounters an encoding \fIname\fR that has not
been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR
from the \fBencoding\fR subdirectory of each directory that Tcl searches
for its script library. If the encoding file exists, but is
malformed, an error message will be left in \fIinterp\fR.
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 | Encoding profiles define the manner in which errors in the encoding transforms are handled by the encoding functions. An application can specify the profile to be used by OR-ing the \fBflags\fR parameter passed to the function with at most one of \fBTCL_ENCODING_PROFILE_TCL8\fR, \fBTCL_ENCODING_PROFILE_STRICT\fR or \fBTCL_ENCODING_PROFILE_REPLACE\fR. These correspond to the \fBtcl8\fR, \fBstrict\fR and \fBreplace\fR profiles respectively. If none are specified, a version-dependent default profile is used. | | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 | Encoding profiles define the manner in which errors in the encoding transforms are handled by the encoding functions. An application can specify the profile to be used by OR-ing the \fBflags\fR parameter passed to the function with at most one of \fBTCL_ENCODING_PROFILE_TCL8\fR, \fBTCL_ENCODING_PROFILE_STRICT\fR or \fBTCL_ENCODING_PROFILE_REPLACE\fR. These correspond to the \fBtcl8\fR, \fBstrict\fR and \fBreplace\fR profiles respectively. If none are specified, a version-dependent default profile is used. The default profile is \fBstrict\fR. .PP For details about profiles, see the \fBPROFILES\fR section in the documentation of the \fBencoding\fR command. .SH "SEE ALSO" encoding(n) .SH KEYWORDS utf, encoding, convert |
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType ,Tcl_FreeInternalRep, Tcl_InitStringRep, Tcl_HasStringRep ,Tcl_NewObjInterface, Tcl_NewObjType , Tcl_StoreInternalRep, Tcl_FetchInternalRep \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_RegisterObjType\fR(\fItypePtr\fR) .sp const Tcl_ObjType * |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | .sp char * \fBTcl_InitStringRep\fR(\fIobjPtr, bytes, numBytes\fR) .sp int \fBTcl_HasStringRep\fR(\fIobjPtr\fR) .sp void \fBTcl_StoreInternalRep\fR(\fIobjPtr, typePtr, irPtr\fR) .sp Tcl_ObjInternalRep * \fBTcl_FetchInternalRep\fR(\fIobjPtr, typePtr\fR) .fi .SH ARGUMENTS | > > > > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | .sp char * \fBTcl_InitStringRep\fR(\fIobjPtr, bytes, numBytes\fR) .sp int \fBTcl_HasStringRep\fR(\fIobjPtr\fR) .sp Tcl_ObjInterface * Tcl_NewObjInterface() .sp Tcl_ObjType * \fBTcl_NewObjType\fR() .sp void \fBTcl_StoreInternalRep\fR(\fIobjPtr, typePtr, irPtr\fR) .sp Tcl_ObjInternalRep * \fBTcl_FetchInternalRep\fR(\fIobjPtr, typePtr\fR) .fi .SH ARGUMENTS |
| ︙ | ︙ | |||
66 67 68 69 70 71 72 73 74 75 76 77 78 79 | .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 | > > > > > > > > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | .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_NewObjType\fR allocates a new \fBTcl_ObjType\fR and returns a pointer to it. .PP \fBTcl_NewObjInterface\fR allocates a new \fBTcl_ObjInterface\fR and returns a pointer to it. .PP \fBTcl_ObjTypeSetInterface\fR sets the given \fBTcl_ObjInterface\fB for the given \fBTcl_ObjType\fR. .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 |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | .CE where the contents are exactly the existing contents of the union in the \fIinternalRep\fR field of the \fITcl_Obj\fR struct. This definition permits us to pass internal representations and pointers to them as arguments and results in public routines. .SH "THE TCL_OBJTYPE STRUCTURE" .PP | | < | | | | | < < < < < < < < < < | 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 |
.CE
where the contents are exactly the existing contents of the union in the
\fIinternalRep\fR field of the \fITcl_Obj\fR struct.
This definition permits us to pass internal representations and pointers to
them as arguments and results in public routines.
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new value types by defining procedures for the
funtion types described below. An extension may also pass to
\fBTcl_RegisterObjType\fR a pointer to a custom Tcl_ObjType structure in order
to permit other extensions to look up the Tcl_ObjType by name with the
\fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is defined as
follows:
.PP
.CS
typedef struct {
const char *\fIname\fR;
Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR;
Tcl_DupInternalRepProc *\fIdupIntRepProc\fR;
Tcl_UpdateStringProc *\fIupdateStringProc\fR;
Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR;
size_t \fIversion\fR;
} \fBTcl_ObjType\fR;
.CE
.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
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 | Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. .SS "THE VERSION FIELD" .PP The \fIversion\fR member provides for future extensibility of the | | | | < < < < < | < < < < < < < < < < < | | < < < | | < | < > > | < < < < < < < < | < < < < | < | < < < | < < | < < < < < < | > | < > | | | | < < < < | < < | | | | | < < < < < < < | | | < | | < | | | < > | | | | | < | < | < < < < < | | < < < < < | 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 | Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. .SS "THE VERSION FIELD" .PP The \fIversion\fR member provides for future extensibility of the structure and should be set to 0 for compatibility of ObjType definitions prior to version 9.0. Specifics about versions will be described further in the sections below. .SH "OTHER OPERATIONS" .PP A procedure for each of the type definitions below may be registered for applying an operation to the Tcl_Obj value. For example, if a function of type \fITcl_ObjInterfaceStringLengthProc\fR is registered, then if provides the length of the string representation of the value. If a function of type \fITcl_ObjInterfaceListLengthProc\fR is registered, then it provides the number of items in the list represented by the value. It is not necessary to implement all procedures. If a particular procedure is NULL, Tcl attempts to interpret the value as a type which supports the requested operation. For example, to perform a list index operation, The Tcl_Obj may be interpreted as \fBtclListType\fR if possible. .PP See the following typedef lines in .cs tcl.h .ce for the procedures that may registered. .RS list operations .RS .CS Tcl_ObjInterfaceListAllProc Tcl_ObjInterfaceListAppendProc Tcl_ObjInterfaceListAppendlistProc Tcl_ObjInterfaceListContainsProc Tcl_ObjInterfaceListIndexProc Tcl_ObjInterfaceListIndexEndProc Tcl_ObjInterfaceListIsSortedProc Tcl_ObjInterfaceListLengthProc Tcl_ObjInterfaceListRangeProc Tcl_ObjInterfaceListRangeEndProc Tcl_ObjInterfaceListReplaceProc Tcl_ObjInterfaceListReplaceListProc Tcl_ObjInterfaceListReverseProc Tcl_ObjInterfaceListSetProc Tcl_ObjInterfaceListSetDeepProc .CE .RE string operations .RS .CS Tcl_ObjInterfaceStringIndexProc Tcl_ObjInterfaceStringIndexEndProc Tcl_ObjInterfaceStringIsEmptyProc Tcl_ObjInterfaceStringLengthProc Tcl_ObjInterfaceStringRangeProc Tcl_ObjInterfaceStringRangeEndProc .CE .RE .RE .SH "REFERENCE COUNT MANAGEMENT" .PP The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared value; this function will not modify the reference count of that value, but will modify its contents. If \fIobjPtr\fR is not (interpretable as) a list, this function will set the interpreter result and produce an error; using an unshared empty value is strongly recommended. |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | > | > | | | < | | < | < < < < < < < < < | | < < > | | < < | | < < < < < < < | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 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 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) '\" Copyright (c) 2018 Nathan Coulter. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SaveInterpState 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState \- Save and restore the state of an an interpreter. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_InterpState \fBTcl_SaveInterpState\fR(\fIinterp, status\fR) .sp int \fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) .sp \fBTcl_DiscardInterpState\fR(\fIstate\fR) .fi .SH ARGUMENTS .AS Tcl_InterpState savedPtr .AP Tcl_Interp *interp in The interpreter for the operation. .AP int status in The return code for the state. .AP Tcl_InterpState state in A token for saved state. .BE .SH DESCRIPTION .PP These routines save the state of an interpreter before a call to a routine such as \fBTcl_Eval\fR, and restore the state afterwards. .PP \fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the result of a script, including the resulting value, the return code passed as \fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. It returns a token for the saved state. The interpreter result is not reset and no interpreter state is changed. .PP \fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and returns the \fIstatus\fR originally passed in the corresponding call to \fBTcl_SaveInterpState\fR. .PP If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called to release it. A token used to discard or restore state must not be used again. .SH KEYWORDS result, state, interp |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .fi .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out | | | < | | | | < | | | | < | < | < | < | < | < > | < < < < < < < < | | < < < | < | < < < | | < | | < > | < < | < | | < < < < < < | < | | < | < < < < < | < < | | | < | | | | < < < | | > > < | | < | | < < < | | < < | | | < | | | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
\fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR)
.sp
\fBTcl_AppendElement\fR(\fIinterp, element\fR)
.fi
.SH ARGUMENTS
.AS Tcl_FreeProc sourceInterp out
.AP Tcl_Interp *interp out
The interpreter get or set the result for.
.AP Tcl_Obj *objPtr in
A value to set the result to.
.AP char *result in
The string value set the result to, or to append to the existing result.
.AP "const char" *element in
The string value to append as a list element
to the existing result of \fIinterp\fR.
.AP Tcl_FreeProc *freeProc in
Pointer to a procedure to call to release storage at
\fIresult\fR.
.AP Tcl_Interp *sourceInterp in
The interpreter to transfer the result and return options from.
.AP Tcl_Interp *targetInterp in
The interpreter to transfer the result and return options to.
.AP int code in
Return code value that controls transfer of return options.
.BE
.SH DESCRIPTION
.PP
These procedures manipulate the result of an interpreter. Some procedures
provide a Tcl_Obj interface while others provide a string interface. For
example, \fBTcl_SetObjResult\fR accepts a Tcl_Obj and \fBTcl_SetResult\fR
accepts a char *. Similarly, \fBTcl_GetObjResult\fR produces a Tcl_Obj * and
\fBTcl_GetStringResult\fR produces a char *. The procedures can be mixed and
matched. For example, if \fBTcl_SetObjResult\fR is called to set the result to
a Tcl_Obj value, and then \fBTcl_GetStringResult\fR is called, it returns a
char * (but see caveats below).
.PP
\fBTcl_SetObjResult\fR sets \fIobjPtr\fR as the result for \fIinterp\fR,
replacing any existing result.
.PP
\fBTcl_GetObjResult\fR returns the result for \fIinterp\fR, without
incrementing its reference count.
.PP
\fBTcl_SetResult\fR sets \fIresult\fR as the result for \fIinterp\fR, replacing
any existing result, and calls \fIfreeProc\fR to free \fIresult\fR. See \fBTHE
TCL_FREEPROC ARGUMENT TO TCL_SETRESULT\fR below. If \fIresult\fR is
\fBNULL\fR, ignores \fIfreeProc\fR and sets the result for \fIinterp\fR to
point to the empty string.
.PP
\fBTcl_GetStringResult\fR returns the result for \fIinterp\fR as a string, i.e.
the bytes of the Tcl_Obj for the result, which can be decoded using
\fBTcl_UtfToExternal\fR. This value is freed when its corresponding Tcl_Obj is
freed.Programmers are encouraged to use the newer Tcl_Obj API procedures, e.g.
to call \fBTcl_GetObjResult\fR instead.
.PP
\fBTcl_ResetResult\fR sets the empty string as the result for \fIinterp\fR and
clears the error state managed by \fBTcl_AddErrorInfo\fR,
\fBTcl_AddObjErrorInfo\fR, and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR builds up a result from smaller pieces, appending each
\fIresult\fR in order to the current result for \fIinterp\fR. It may be called
repeatedly as additional pieces of the result are produced, and manages the
storage for the \fIinterp\fR's result, allocating a larger result area if
necessary. It also manages conversion to and from the \fIresult\fR field of
the \fIinterp\fR to handle backward-compatibility with old-style extensions.
Any number of \fIresult\fR arguments may be passed in a single call; the last
argument in the list must be (char *)NULL.
.PP
\fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to
\fItargetInterp\fR, both of which must have been created in the same thread,
resets the result in \fIsourceInterp\fR, and moves the return options
dictionary as controlled by the return code value \fIcode\fR in the same manner
as \fBTcl_GetReturnOptions\fR.
.PP
If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
The following procedures are deprecated since they manipulate the Tcl result as
a string. Procedures such as \fBTcl_SetObjResult\fR can be significantly more
efficient.
.PP
\fBTcl_AppendElement\fR is like \fBTcl_AppendResult\fR, but it appends only one
piece, and also appends that piece as a list item.
\fBTcl_AppendElement\fR adds backslashes or braces as necessary to ensure that
\fIelement\fR is properly formatted as a list item. Under normal conditions,
\fBTcl_AppendElement\fR adds a space character to \fIinterp\fR's result just
before adding the new list element, so that the list elements in the result are
properly separated. However if the new list element is the first item in the
list or sublist (i.e. \fIinterp\fR's current result is empty, or consists of
the single character
.QW { ,
or ends in the characters
.QW " {" )
then no space is added.
.SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT"
.PP
\fIFreeProc\fR has the following type:
.PP
.CS
typedef void \fBTcl_FreeProc\fR(
void *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, \fIblockPtr\fR is the \fIresult\fR value passed
to \fBTcl_SetResult\fR.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 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. '\" .TH Tcl n "8.6" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME Tcl \- Tool Command Language .SH SYNOPSIS Summary of Tcl language syntax. .BE .SH DESCRIPTION .PP The following rules define the syntax and semantics of the Tcl language: | > > > > > > > > | | | < < < | | < | > > | | < | > > | | < | > | > > > > > > > | < > > | > > > > > > | | | < | > | > > | < < > > > | | < < | < | | | | | > > | < < | > | > | < | | | < < < < < < | < > | | | < < < < | | < < < < | | | | < > > | < | < < < < < < < < < < < | < < | < < | < | < < > | < < < < < < < > > | | < | < | | < < | | > | > | > | > | > | > | > | | | | < | | > < | | | < < | < < | | < < | | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 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 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2023 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" You may distribute and/or modify this program under the terms of the GNU
'\" Affero General Public License as published by the Free Software Foundation,
'\" either version 3 of the License, or (at your option) any later version.
'\"
'\" See the file "COPYING" for information on usage and redistribution.
'\"
.TH Tcl n "8.6" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
Tcl \- Tool Command Language
.SH SYNOPSIS
Summary of Tcl language syntax.
.BE
.SH DESCRIPTION
.PP
The following rules define the syntax and semantics of the Tcl language:
.
.IP "[1] \fBScript.\fR"
A script is composed of zero or more commands delimited by semi-colons or
newlines.
.IP "[2] \fBCommand.\fR"
A command is composed of zero or more words delimited by whitespace. The
replacement for a substitution is included verbatim in the word. For example, a
space in the replacement is included in the word rather than becoming a
delimiter, and \fI\\\\\fR becomes a single backslash in the word. Each word is
processed from left to right and each substitution is performed as soon as it
is complete.
For example, the command
.RS
.PP
.CS
set y [set x 0][incr x][incr x]
.CE
.PP
is composed of three words, and sets the value of \fIy\fR to \fI012\fR.
.PP
If hash
.PQ #
is the first character of what would otherwise be the first word of a command,
all characters up to the next newline are ignored.
.RE
.
.IP "[3] \fBBraced word.\fR"
If a word is enclosed in braces
.PQ {
and
.PQ } ""
, the braces are removed and the enclosed characters become the word. No
substitutions are performed. Nested pairs of braces may occur within the word.
A brace preceded by an odd number of backslashes is not considered part of a
pair, and neither brace nor the backslashes are removed from the word.
.
.IP "[4] \fBQuoted word.\fR"
If a word is enclosed in double quotes
.PQ \N'34'
, the double quotes are removed and the enclosed characters become the word.
Substitutions are performed.
.
.IP "[5] \fBList.\fR"
A list has the form of a single command. Newline is whitespace, and semicolon
has no special interpretation. There is no script evaluation so there is no
argument expansion, variable substitution, or command substitution: Dollar-sign
and open bracket have no special interpretation, and what would be argument
expansion in a script is invalid in a list.
.
.IP "[6] \fBArgument expansion.\fR"
If
.QW {*}
prefixes a word, it is removed. After any remaining enclosing braces or quotes
are processed and applicable substitutions performed, the word, which must
be a list, is removed from the command, and in its place each word in the
list becomes an additional word in the command. For example,
.CS
cmd a {*}{b [c]} d {*}{$e f {g h}}
.CE
is equivalent to
.CS
cmd a b {[c]} d {$e} f {g h} .
.CE
.
.IP "[7] \fBEvaluation.\fR"
To evaluate a script, an interpreter evaluates each successive command. The
first word identifies a procedure, and the remaining words are passed to that
procedure for further evaluation. The procedure interprets each argument in
its own way, e.g. as an integer, variable name, list, mathematical expression,
script, or in some other arbitrary way. The result of the last command is the
result of the script.
.
.IP "[8] \fBCommand substitution.\fR"
Each pair of brackets
.PQ [
and
.PQ ] ""
encloses a script and is replaced by the result of that script.
.IP "[9] \fBVariable substitution.\fR"
Each of the following forms begins with dollar sign
.PQ $
and is replaced by the value of the identified variable. \fIname\fR names the
variable and is composed of ASCII letters (\fBA\fR\(en\fBZ\fR and
\fBa\fR\(en\fBz\fR), digits (\fB0\fR\(en\fB9\fR), underscores, or namespace
delimiters (two or more colons). \fIindex\fR is the name of an individual
variable within an array variable, and may be empty.
.RS
.TP 15
\fB$\fIname\fR
.
\fIname\fR may not be empty.
.TP 15
\fB$\fIname\fB(\fIindex\fB)\fR
.
\fIname\fR may be empty. Substitutions are performed on \fIindex\fR.
.TP 15
\fB${\fIname\fB}\fR
.
\fIname\fR may be empty.
.TP 15
\fB${\fIname(index)\fB}\fR
.
\fIname\fR may be empty. No substitutions are performed.
.RE
Variables that are not accessible through one of the forms above may be
accessed through other mechanisms, e.g. the \fBset\fR command.
.IP "[10] \fBBackslash substitution.\fR"
Each backslash
.PQ \e
that is not part of one of the forms listed below is removed, and the next
character is included in the word verbatim, which allows the inclusion of
characters that would normally be interpreted, namely whitespace, braces,
brackets, double quote, dollar sign, and backslash. The following sequences
are replaced as described:
.RS
.RS
.RS
.TP 7
\e\fBa\fR
.
Audible alert (bell) (U+7).
.TP 7
\e\fBb\fR
.
Backspace (U+8).
.TP 7
\e\fBf\fR
.
Form feed (U+C).
.TP 7
\e\fBn\fR
.
Newline (U+A).
.TP 7
\e\fBr\fR
.
Carriage-return (U+D).
.TP 7
\e\fBt\fR
.
Tab (U+9).
.TP 7
\e\fBv\fR
.
Vertical tab (U+B).
.TP 7
\e\fB<newline>\fIwhiteSpace\fR
.
Newline preceded by an odd number of backslashes, along with the consecutive
spaces and tabs that immediately follow it, is replaced by a single space.
Because this happens before the command is split into words, it occurs even
within braced words, and if the resulting space may subsequently be treated as
a word delimiter.
.TP 7
\e\e
.
Backslash
.PQ \e "" .
.TP 7
\e\fIooo\fR
.
Up to three octal digits form an eight-bit value for a Unicode character in the
range \fI0\fR\(en\fI377\fR, i.e. U+0\(enU+FF. Only the digits that result in a
number in this range are consumed.
.TP 7
\e\fBx\fIhh\fR
.
Up to two hexadecimal digits form an eight-bit value for a Unicode character in
the range \fI0\fR\(en\fIFF\fR.
.TP 7
\e\fBu\fIhhhh\fR
.
Up to four hexadecimal digits form a 16-bit value for a Unicode character in
the range \fI0\fR\(en\fIFFFF\fR.
.TP 7
\e\fBU\fIhhhhhhhh\fR
.
Up to eight hexadecimal digits form a 21-bit value for a Unicode character in
the range \fI0\fR\(en\fI10FFFF\fR. Only the digits that result in a number in
this range are consumed.
.RE
.RE
.PP
.RE
.
.SH KEYWORDS
backslash, command, comment, script, substitution, variable
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH abstract n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::abstract \- a class that does not allow direct instances of itself | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH abstract n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::abstract \- a class that does not allow direct instances of itself |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1990-1994 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. '\" .TH after n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME after \- Execute a command after a time delay | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1990-1994 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH after n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME after \- Execute a command after a time delay |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH append n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME append \- Append to variable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH append n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME append \- Append to variable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1993-1994 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. '\" .TH array n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1993-1994 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH array n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1990-1994 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. '\" .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME bgerror \- Command invoked to process background errors | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1990-1994 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME bgerror \- Command invoked to process background errors |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH binary n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME binary \- Insert and extract fields from binary strings .SH SYNOPSIS | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH binary n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME binary \- Insert and extract fields from binary strings .SH SYNOPSIS |
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | .PP which returns a binary string equivalent to: .PP .CS \fB\e254\fR .CE .PP | | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | .PP which returns a binary string equivalent to: .PP .CS \fB\e254\fR .CE .PP (i.e. \fB\exac\fR) by truncating the high-bits of the character, and which is probably not what is desired. .RE .IP \fBA\fR 5 This form is the same as \fBa\fR except that spaces are used for padding instead of nulls. For example, .RS |
| ︙ | ︙ | |||
305 306 307 308 309 310 311 | .CS \fBbinary format\fR B5B* 11100 111000011010 .CE .PP will return a binary string equivalent to: .PP .CS | | | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 | .CS \fBbinary format\fR B5B* 11100 111000011010 .CE .PP will return a binary string equivalent to: .PP .CS \fB\exe0\exe1\exa0\fR .CE .RE .IP \fBH\fR 5 Stores a string of \fIcount\fR hexadecimal digits in high-to-low within each byte in the output binary string. \fIArg\fR must contain a sequence of characters in the set .QW 0123456789abcdefABCDEF . |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 | .CS \fBbinary format\fR H3H*H2 ab DEF 987 .CE .PP will return a binary string equivalent to: .PP .CS | | | | 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 | .CS \fBbinary format\fR H3H*H2 ab DEF 987 .CE .PP will return a binary string equivalent to: .PP .CS \fB\exab\ex00\exde\exf0\ex98\fR .CE .RE .IP \fBh\fR 5 This form is the same as \fBH\fR except that the digits are stored in low-to-high order within each byte. This is seldom required. For example, .RS .PP .CS \fBbinary format\fR h3h*h2 AB def 987 .CE .PP will return a binary string equivalent to: .PP .CS \fB\exba\ex00\exed\ex0f\ex89\fR .CE .RE .IP \fBc\fR 5 Stores one or more 8-bit integer values in the output string. If no \fIcount\fR is specified, then \fIarg\fR must consist of an integer value. If \fIcount\fR is specified, \fIarg\fR must consist of a list containing at least that many integers. The low-order 8 bits of each integer |
| ︙ | ︙ | |||
369 370 371 372 373 374 375 |
.CS
\fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
.CS
\fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR
.CE
.PP
whereas:
.PP
.CS
\fBbinary format\fR c {2 5}
.CE
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
.CS
\fBbinary format\fR s3 {3 -3 258 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | | 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 |
.CS
\fBbinary format\fR s3 {3 -3 258 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex03\ex00\exfd\exff\ex02\ex01\fR
.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that it stores one or more
16-bit integers in big-endian byte order in the output string. For
example,
.RS
.PP
.CS
\fBbinary format\fR S3 {3 -3 258 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex00\ex03\exff\exfd\ex01\ex02\fR
.CE
.RE
.IP \fBt\fR 5
This form (mnemonically \fItiny\fR) is the same as \fBs\fR and \fBS\fR
except that it stores the 16-bit integers in the output string in the
native byte order of the machine where the Tcl script is running.
To determine what the native byte order of the machine is, refer to
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 |
.CS
\fBbinary format\fR i3 {3 -3 65536 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | | 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 |
.CS
\fBbinary format\fR i3 {3 -3 65536 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex03\ex00\ex00\ex00\exfd\exff\exff\exff\ex00\ex00\ex01\ex00\fR
.CE
.RE
.IP \fBI\fR 5
This form is the same as \fBi\fR except that it stores one or more one
or more 32-bit integers in big-endian byte order in the output string.
For example,
.RS
.PP
.CS
\fBbinary format\fR I3 {3 -3 65536 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex00\ex00\ex00\ex03\exff\exff\exff\exfd\ex00\ex01\ex00\ex00\fR
.CE
.RE
.IP \fBn\fR 5
This form (mnemonically \fInumber\fR or \fInormal\fR) is the same as
\fBi\fR and \fBI\fR except that it stores the 32-bit integers in the
output string in the native byte order of the machine where the Tcl
script is running.
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
.CS
\fBbinary format\fR f2 {1.6 3.4}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
.CS
\fBbinary format\fR f2 {1.6 3.4}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\excd\excc\excc\ex3f\ex9a\ex99\ex59\ex40\fR
.CE
.RE
.IP \fBr\fR 5
This form (mnemonically \fIreal\fR) is the same as \fBf\fR except that
it stores the single-precision floating point numbers in little-endian
order. This conversion only produces meaningful output when used on
machines which use the IEEE floating point representation (very
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 |
.CS
\fBbinary format\fR d1 {1.6}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
.CS
\fBbinary format\fR d1 {1.6}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\fB\ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f\fR
.CE
.RE
.IP \fBq\fR 5
This form (mnemonically the mirror of \fBd\fR) is the same as \fBd\fR
except that it stores the double-precision floating point numbers in
little-endian order. This conversion only produces meaningful output
when used on machines which use the IEEE floating point representation
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 | .QW \fB*\fR , then all of the remaining hex digits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one hex digit will be scanned. For example, .RS .PP .CS | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | .QW \fB*\fR , then all of the remaining hex digits in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one hex digit will be scanned. For example, .RS .PP .CS \fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2 .CE .PP will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and \fB051f34\fR stored in \fIvar2\fR. .RE .IP \fBh\fR 5 This form is the same as \fBH\fR, except the digits are taken in |
| ︙ | ︙ | |||
846 847 848 849 850 851 852 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 16-bit integer will be scanned. For example, .RS .PP .CS | | | | 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 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 16-bit integer will be scanned. For example, .RS .PP .CS \fBbinary scan\fR \ex05\ex00\ex07\ex00\exf0\exff s2s* var1 var2 .CE .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. Note that the integers returned are signed unless \fBsu\fR is used in place of \fBs\fR. .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that the data is interpreted as \fIcount\fR 16-bit integers represented in big-endian byte order. For example, .RS .PP .CS \fBbinary scan\fR \ex00\ex05\ex00\ex07\exff\exf0 S2S* var1 var2 .CE .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBt\fR 5 The data is interpreted as \fIcount\fR 16-bit signed integers |
| ︙ | ︙ | |||
885 886 887 888 889 890 891 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 32-bit integer will be scanned. For example, .RS .PP .CS | | | | 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 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 32-bit integer will be scanned. For example, .RS .PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str i2i* var1 var2 .CE .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. Note that the integers returned are signed unless \fBiu\fR is used in place of \fBi\fR. .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted as \fIcount\fR 32-bit signed integers represented in big-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBI\fR. For example, .RS .PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str I2I* var1 var2 .CE .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBn\fR 5 |
| ︙ | ︙ | |||
927 928 929 930 931 932 933 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 64-bit integer will be scanned. For example, .RS .PP .CS | | | | 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 | .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one 64-bit integer will be scanned. For example, .RS .PP .CS set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff \fBbinary scan\fR $str wi* var1 var2 .CE .PP will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that the data is interpreted as \fIcount\fR 64-bit signed integers represented in big-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBW\fR. For example, .RS .PP .CS set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0 \fBbinary scan\fR $str WI* var1 var2 .CE .PP will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBm\fR 5 |
| ︙ | ︙ | |||
973 974 975 976 977 978 979 | bytes that are scanned may vary. If the data does not represent a valid floating point number, the resulting value is undefined and compiler dependent. For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS | | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 | bytes that are scanned may vary. If the data does not represent a valid floating point number, the resulting value is undefined and compiler dependent. For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS \fBbinary scan\fR \ex3f\excc\excc\excd f var1 .CE .PP will return \fB1\fR with \fB1.6000000238418579\fR stored in \fIvar1\fR. .RE .IP \fBr\fR 5 This form is the same as \fBf\fR except that the data is interpreted |
| ︙ | ︙ | |||
997 998 999 1000 1001 1002 1003 | This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR double-precision floating point numbers in the machine's native representation. For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS | | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 | This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR double-precision floating point numbers in the machine's native representation. For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS \fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1 .CE .PP will return \fB1\fR with \fB1.6000000000000001\fR stored in \fIvar1\fR. .RE .IP \fBq\fR 5 This form is the same as \fBd\fR except that the data is interpreted |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1993-1994 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. '\" .TH break n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME break \- Abort looping command | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1993-1994 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH break n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME break \- Abort looping command |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH callback n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME callback, mymethod \- generate callbacks to methods | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH callback n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME callback, mymethod \- generate callbacks to methods |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH catch n "8.5" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME catch \- Evaluate script and trap exceptional returns | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH catch n "8.5" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME catch \- Evaluate script and trap exceptional returns |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH cd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cd \- Change working directory | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH cd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cd \- Change working directory |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 2005-2006 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .TH chan n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .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 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 |
'\"
'\" Copyright (c) 2005-2006 Donal K. Fellows
'\" Copyright (c) 2021 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" Copyright (c) 2024 Nathan Coulter
'\"
'\" You may distribute and/or modify this program under the terms of the GNU
'\" Affero General Public License as published by the Free Software Foundation,
'\" either version 3 of the License, or (at your option) any later version.
'\"
'\" See the file "COPYING" for information on usage and redistribution.
.TH chan n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
chan \- Reads, writes and manipulates channels.
.SH SYNOPSIS
\fBchan \fIprocedure\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
\fBchan\fR provides procedures for reading from, writing to, and
otherwise manipulating channels like those created by \fBopen\fR and
\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR
which correspond respectively to the standard input, output, and error streams
of the process.
Available procedures are:
.\" METHOD: blocked
.TP
\fBchan blocked \fIchannel\fR
.
Returns 1 when \fIchannel\fR is non-blocking and the last input operation on
\fIchannel\fR failed because it would have otherwise caused the process to
block, and 0 otherwise.
.\" METHOD: close
.TP
\fBchan close \fIchannel\fR ?\fIdirection\fR?
.
Closes \fIchannel\fR, deleting any existing event handlers established for it,
and returns the empty string. Once both sides of a \fIchannel\fR are closed,
\fIchannel\fR no-longer exists in the current \fBinterp\fR.
.RS
.PP
If \fIdirection\fR, which may be \fBread\fR or \fBwrite\fR or any unique
abbreviation of those words, is given, closes only that side of \fIchannel\fR.
If \fIchannel\fR is read-write and the write side is closed, it becomes
read-only, or if the read side is closed, it becomes write-only.
.PP
.PP
Discards any buffered input before closing the read side of \fIchannel\fR.
Fully flushes any output before closing the write side of \fIchannel\fR unless
it is non-blocking mode, where it makes \fIchannel\fR unavailable, returns
immediately, and flushes any buffered output the background before actually
closing \fIchannel\fR.
.PP
Returns an error if \fIchannel\fR is blocking and error occurs while flushing
output. Produces an error in the same manner as \fBexec\fR if a
process in a command pipeline created by \fBopen\fR returns an error (either by
returning a non-zero exit code or writing to its standard error file
descriptor).
.PP
If \fIchannel\fR is a command pipeline and is in blocking mode, waits
for the connected processes to complete before closing \fIchannel\fR.
.PP
Only affects the current interpreter. If \fIchannel\fR is open in any other
interpreter, its state is unchanged there. See \fBinterp\fR for a description
of channel sharing.
.PP
Closing one side of a socket or command pipeline may cause the underlying
system resource to be closed or destroyed, along with whatever side-effects
that entails for the process on the other side of the pipeline.
.PP
When the last interpreter sharing a channel is destroyed, the channel is
switched to blocking mode, fully flushed, and then closed.
.PP
Channels are automatically closed when an interpreter is destroyed and
also when the process exits.
From 8.6 on (TIP#398), nonblocking channels are no longer switched to
blocking mode when exiting; this guarantees a timely exit even when the
peer or a communication channel is stalled. To ensure proper flushing of
stalled nonblocking channels on exit, one must now either (a) actively
switch them back to blocking or (b) use the environment variable
\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to
.QW \fB0\fR
restores the previous behavior.
.RE
.\" METHOD: configure
.TP
\fBchan configure \fIchannel\fR ?\fIoption\fR? ?\fIvalue\fR? ?\fIoption value\fR?...
.
Sets or gets the configuration of \fIchannel\fR.
.RS
.PP
If no \fIoption\fR or \fIvalue\fR arguments are given, \fBchan configure\fR
returns a dictionary of option names and values for \fIchannel\fR. If
\fIoption\fR is supplied without a \fIvalue\fR, \fBchan configure\fR returns
the current value that option. If one or more values are given, \fBchan
configure\fR sets each of the given options to the corresponding \fIvalue\fR
and returns the empty string.
.PP
The following options are supported for all channels. Each type of
channel may provide additional options. Those options are described in the
relevant documentation. For example, additional options are documented for
\fBsocket\fR, and also for serial devices at \fBopen\fR.
.\" OPTION: -blocking
.TP
\fB\-blocking\fI boolean\fR
.
If \fB\-blocking\fR is set to \fBtrue\fR (default), reading from or writing to
\fIchannel\fR may cause the process to block indefinitely. Otherwise,
operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan
flush\fR, and \fBchan close\fR take care not to block. For non-blocking mode
to work correctly the event loop must be active, e.g. via
\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, so that channel events
are processed.
.\" OPTION: -buffering
.TP
\fB\-buffering\fI newValue\fR
.
If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered
until the internal buffer is full or until \fBchan flush\fR is called. If
\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line
character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after
every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that
connect to terminal-like devices, the default value is \fBline\fR. For
\fBstderr\fR the default value is \fBnone\fR.
.\" OPTION: -buffersize
.TP
\fB\-buffersize\fI newSize\fR
.
\fInewSize\fR, an integer no greater than one million, is the size in bytes of
any input or output buffers subsequently allocated for \fIchannel\fR.
.\" OPTION: -encoding
.TP
\fB\-encoding\fR \fIencoding\fR
.
Sets the encoding of \fIchannel\fR to \fIencoding\fR which should be one of the
encodings returned by \fBencoding names\fR.
Input is converted from the encoding into Unicode, and output is converted
from Unicode to the encoding.
.RS
.PP
The encoding of a new channel is the value of \fBencoding system\fR,
which returns the platform- and locale-dependent system encoding used to
interface with the operating system,
.RE
.\" OPTION: -eofchar
.TP
\fB\-eofchar\fI char\fR
.
\fIchar\fR signals the end of the data when it is encountered in the input.
If \fIchar\fR is the empty string, there is no special character that marks
the end of the data.
.RS
.PP
The default value is the empty string. The acceptable range is \ex01 -
\ex7f. A value outside this range results in an error.
.RE
.VS "TCL8.7 TIP656"
.\" OPTION: -profile
.TP
\fB\-profile\fI profile\fR
.
Indicates the encoding profile to be used on \fIchannel\fR. The encoding
transforms in use for the input and output of \fIchannel\fR will then be
subject to the rules of that profile. Any failures will result in a channel
error. See \fBPROFILES\fR in the \fBencoding(n)\fR documentation for details
about encoding profiles.
.VE "TCL8.7 TIP656"
.\" OPTION: -translation
.TP
\fB\-translation\fI translation\fR
.TP
\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR
.
In Tcl a single line\-feed character (\fBlf\fR) represents the end of a
line. However, the end of a line of a may be represented differently on
different platforms, or even for different devices on the same platform. For
example, in UNIX \fBlf\fR is normally used in files, and a carriage-return
character followed by a line-feed character (\fBcrlf\fR) is
normally used in network connections. Therefore, when decoding, e.g. with
\fBchan gets\fR and \fBchan read\fR, each particular end-of-line representation
is translated into \fBlf\fR for Tcl. Before encoding, e.g. with \fBchan
puts\fR, each \fBlf\fR is translated to the approprate end\-of\-line
representation for the target. The default translation setting is \fBauto\fR,
which handles all the common cases. When needed, \fB\-translation\fR provides
explicit control over the end\-of\-line representation.
.RS
.PP
Returns the input translation if \fIchannel\fR is read\-only, the output
translation if \fIchannel\fR is write\-only, and both the input translation and
the output translation if \fIchannel\fR is read\-write. When two
translations are given, they indicate the input and output translation
respectively. When only one translation is given for a read\-write channel, it
is the translation for both input and output. The following values are
currently supported:
.IP \fBauto\fR
The default. For input each occurrence of \fBlf\fR, carriage-return character
(\fBcr\fR), or \fBcrlf\fR is translated into \fBlf\fR for Tcl. For output,
each \fBlf\fR is translated into a the appropriate representation for the
target: For all Unix variants it is \fBlf\fR, and for all Windows variants it
is \fBcrlf\fR, except that for sockets on all platforms it is \fBcrlf\fR for
both input and output.
.IP \fBbinary\fR
Like \fBlf\fR, prevents end-of-line translation, but also sets \fB\-eofchar\fR
to the empty string to disable it, and sets \fB\-encoding\fR to
\fBiso8859-1\fR. This one argument fully configures \fIchannel\fR for bytewise
input and output: Each byte is read from \fIchannel\fR as the Unicode
character having the same value as that byte, and each character written to
\fIchannel\fR is encoded a single byte having the value of the character. This
makes it possible to treat text as byte values as long as each character in
remains in the range of 0 to 255 so that the correspondance between a character
and a byte is maintained. For example, A JPEG image can be read from
\fIchannel\fR, manipulated, and then written back to \fIchannel\fR.
.IP \fBcr\fR
The end of a line is encoded as \fBcr\fR. For input, each \fBcr\fR is
translated to \fBlf\fR, and for output each \fBlf\fR is translated to \fBcr\fR.
.IP \fBcrlf\fR
The end of a line is encoded as a \fBcrlf\fR. For input, each \fBcrlf\fR is
translated to \fBlf\fR. For output, each \fBlf\fR is translated to \fBcrlf\fR.
This translation is typically used for network connections, and is also used on
Windows systems.
.IP \fBlf\fR
The end of a line is encoded as \fBlf\fR so no translations occur during either
input or output. This translation is typically used on UNIX platforms,
.RE
.RE
.\" METHOD: copy
.TP
\fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.
Reads characters from \fIinputChan\fR and writes them to \fIoutputChan\fR until
all characters are copied, blocking until the copy is complete and returning
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 | .QW "channel busy" error. .RE .\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . | | < | < | < < < < < | | < | < | < | < < < > | < < | | < < | < < < < > | | | | < | | | < | < < < < | | < < | < | | | | | > | < > | | < < | | < | > > | | < < > | | | | | | > | | | | | | < | | | | < | | | | < < < < < < < < < > < < < < | < | | < | < | | < | | < < < < < < < < < < < < < | > | < < < | < > | < < < < < < < > < | < > | | | | | < | < | < | > > | > | | | | | | > | < > | | < | | | | > | < | | | > > | < > > > > > > > | < | | | | < | > | | < | | | < > < < < | | < > < < | | < < < < < | > | | < | | < < > | < | | < < | < | < < < | | | < < > | < | < | | > | | < < | | | | | | < | > | | < | | | | | < | < < | < | | | | | | < < | < < < | < < < | | | < < < < < < < < < | < < | | < | | > | | < | | | | < > | < | | | | | | < | < < < < < | < < | < | < | | | | < | | | < < < | | < | 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 | .QW "channel busy" error. .RE .\" METHOD: create .TP \fBchan create \fImode cmdPrefix\fR . Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR as its handler, and returns the name of the channel. \fBcmdPrefix\fR is the first words of a command that provides the interface for a \fBrefchan\fR. .RS .PP \fBImode\fR is a list of one or more of the strings .QW \fBread\fR or .QW \fBwrite\fR , indicating whether the channel is a read channel, a write channel, or both. It is an error if the handler does not support the chosen mode. .PP The handler is called as needed from the global namespace at the top level, and command resolution happens there at the time of the call. If the handler is renamed or deleted any subsequent attempt to call it is an error, which may not be able to describe the failure. .PP The handler is always called in the interpreter and thread it was created in, even if the channel was shared with or moved into a different interpreter in a different thread. This is achieved through event dispatch, so if the event loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or using Tk, the thread performing the channel operation \fIblocks indefinitely\fR, resulting in deadlock. .PP One side of a channel may be in one thread while the other side is in a different thread, providing a stream-oriented bridge between the threads. This provides a method for regular stream communication between threads as an alternative to sending commands. .PP When the interpreter the handler is in is deleted each channel associated with the handler is deleted as well, regardless of which interpreter or thread it is currently in or shared with. .PP \fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The handler is always called in the safe interpreter it was created in. .RE .\" METHOD: eof .TP \fBchan eof \fIchannel\fR . Returns 1 if the last read on \fIchannel\fR failed because the end of the data was already reached, and 0 otherwise. .\" METHOD: event .TP \fBchan event \fIchannel event\fR ?\fIscript\fR? . Arranges for the given script, called a \fBchannel event handler\fR, to be called whenever the given event, either .QW \fBreadable\fR or .QW \fBwritable\fR occurs on \fIchannel\fR, replacing any script that was previously set. If \fIscript\fR is the empty string the current handler is deleted. If \fIscript\fR is omitted, either the existing script or the empty string is returned. For handlers to be processed, the event loop must be entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk. .RS .PP \fIscript\fR is evaluated at the global level in the interpreter it was established in. Any resulting error is handled in the background, i.e. via \fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy handler, the handler is deleted if \fIscript\fR returns an error so that it is not evaluated again. .PP Without an event handler, \fBchan gets\fR or \fBchan read\fR on \fIchannel\fR in blocking mode may block until data becomes available, during which the thread is unable to perform other work or respond to events on other channels. This could cause the application to appear to .QW "freeze up" \&. Channel event handlers allow events on \fIchannel\fR to direct channel handling so that the reader or writer can continue to perform other processing while waiting for a channel to become available and then handle channel operations when the channel is ready for the operation. .PP \fIchannel\fR is considered to be readable if there is unread data available on the underlying device. \fIchannel\fR is also considered to be readable if there is unread data in an input buffer, except in the special case where the most recent attempt to read from \fIchannel\fR was a \fBchan gets\fR call that could not find a complete line in the input buffer. This feature allows a file to be read a line at a time in non-blocking mode using events. A channel is also considered to be readable if an end of file or error condition is present on the underlying file or device. It is important for \fIscript\fR to check for these conditions and handle them appropriately; for example, if there is no special check for end of file, an infinite loop may occur where \fIscript\fR reads no data, returns, and is immediately invoked again. .PP \fIchannel\fR 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. Note that client sockets opened in asynchronous mode become writable when they become connected or if the connection fails. .PP Event-driven channel handling works best for channels in non-blocking mode. In blocking mode \fIchannel\fR blocks when \fBchan puts\fR writes more data than \fIchannel\fR can accept at the moment, and also when \fBchan gets\fR or \fBchan read\fR requests more data than is currently available. When \fIchannel\fR blocks, the thread can not do any other processing or service any other events. When \fIchannel\fR is in non-blocking mode a thread may to carry on with other work and get back to \fIchannel\fR at the right time. .RE .\" METHOD: flush .TP \fBchan flush \fIchannel\fR . If \fIchannel\fR is in blocking mode, flushes all buffered output to the destination and then returns. If \fIchannel\fR is non-blocking, returns immediately while all buffered output is flushed in the background as soon as possible. .\" METHOD: gets .TP \fBchan gets \fIchannel\fR ?\fIvarName\fR? . Reads and returns the characters up to but not including the next end\-of\-line representation or the end of the input, whichever comes first. If \fIvarName\fR is given, stores the result in the variable named \fIvarName\fR and returns the length of the line. If the line was terminated by the end of the input rather than an end-of-line representation, a subsequent call to \fBchan eof\fR returns 1. If more input is needed and \fIchannel\fR is non-blocking, returns the empty string or if \fIvarName\fR was given returns \-1. .RS .PP If necessary use \fIvarName\fR along with a return value of 0 to determine that a line is actually empty, as opposed to more input being needed to provide a complete line. \fBchan eof\fR can then be used to determine whether more input is forthcoming. .PP Returns an error with the POSIX error code \fBEILSEQ\fR if the encoding profile for \fIchannel\fR is \fBstrict\fR and a decoding error occurs, in which case the current position is unchanged and it may be possible to change the encoding and continue to read the input. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: isbinary .TP \fBchan isbinary \fIchannel\fR . Returns 1 if \fIchannel\fR is configured as described for \fB-translation binary\fR, and 0 otherwise. .\" METHOD: names .TP \fBchan names\fR ?\fIpattern\fR? . Returns a list of all channel names, or if \fIpattern\fR is given, only those names that match according to the rules of \fBstring match\fR. .\" METHOD: pending .TP \fBchan pending \fImode channel\fR . Returns the number of bytes of input when \fImode\fR is .QW\fBinput\fR , or output when \fImode\fR is .QW\fBoutput\fR , that are currently internally buffered for \fIchannel\fR. Useful in a readable event callback to impose limits on input line length to avoid a potential denial-of-service attack where an extremely long line exceeds the available memory to buffer it. Returns -1 if \fIchannel\fR was not opened for the mode in question. .\" METHOD: pipe .TP \fBchan pipe\fR . Creates a pipe, i.e. a readable channel and a writable channel, and returns the names of these channels. Data written to the writable channel can be read from the readable channel. Because the pipe is a real system-level pipe, it can be connected to other processes using redirection. For example, to redirect \fBstderr\fR from a subprocess into one channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each onto the writable side of a pipe, closing the writable side immediately thereafter so that EOF is signaled on the read side once the subprocess has closed its output, typically on exit. .RS .PP Due to buffering, data written to one side of a pipe might not immediately become available on the other side. Tcl's own buffers can be configured via \fBchan configure -buffering\fR, but overall behaviour still depends on operating system buffers outside of Tcl's control. Once the write side of the channel is closed, any data remaining in the buffers is flushed through to the read side. It may be useful to arrange for the connected process to flush at some point after writing to the channel or to have it use some system-provided mechanism to configure buffering. When two pipes are connected to the same process, one to send data to the process, and one to read data from the process, a deadlock may occur if the channels are in blocking mode: If reading, the channel may block waiting for data that can never come because buffers are only flushed on subsequent writes, and if writing, the channel may block while waiting for the buffers to become free, which can never happen because the reader can not read while the writer is blocking. To avoid this issue, either put the channels into non-blocking mode and use event handlers, or place the read channel and the write channel in separate interpreters in separate threads. .RE .\" METHOD: pop .TP \fBchan pop \fIchannel\fR . Removes the topmost transformation handler from \fIchannel\fR if there is one, and closes \fIchannel\fR otherwise. The result is normally the empty string, but may be an error in some situations, e.g. when closing the underlying resource results in an error. .\" METHOD: postevent .TP \fBchan postevent \fIchannel eventSpec\fR . For use by handlers established with \fBchan create\fR. Notifies Tcl that that one or more event(s) listed in \fIeventSpec\fR, each of which is either .QW\fBread\fR or .QW\fBwrite\fR. , have occurred. .RS .PP For use only by handlers for \fIchannel\fR which must have been created by \fBchan create\fR. It is an error to post an event for any other kind of channel. .PP Since only the handlers for a reflected channel should post events it is an error to post an event from any interpreter other than the interpreter that created the channel. .PP It is an error to post an event that \fIchannel\fR has no interest in. See \fBwatch\fR in the \fBrefchan\fR documentation for more information .PP \fBchan postevent\fR is available in safe interpreters, as any handler for a reflected channel would have been created, and will be evaluated in that interpreter as well. .RE .\" METHOD: push .TP \fBchan push \fIchannel cmdPrefix\fR . Adds a new transformation handler on top of \fIchannel\fR and returns a handle for the transformation. \fIcmdPrefix\fR is the first words of a command that provides the interface documented for \fBtranschan\fR, and transforms data on \fIchannel\fR, It is an error if handler does not support the mode(s) \fIchannel\fR is in. .\" METHOD: puts .TP \fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannel\fR? \fIstring\fR . Writes \fIstring\fR and a line feed to \fIchannel\fR. If \fB\-nonewline\fR is given, the trailing line feed is not written. The default channel is \fBstdout\fR. .RS .PP Each line feed in the output is translated to the appropriate end of line sequence as per the \fB\-translation\fR configuration setting of \fIchannel\fR. .PP Because Tcl internally buffers output, characters written to \fIchannel\fR may not immediately be available at the destination. Tcl normally delays output until the buffer is full or \fIchannel\fR is closed. \fBchan flush\fR forces output in the direction of the destination. .PP If \fIchannel\fR is in blocking mode and the write buffer fills up, blocks until space in the buffer is available again. If \fIchannel\fR is in non-blocking mode, returns immediately and the data is written in the background as fast possible, constrained by the speed at which the destination accepts it. Data written to a channel in non-blocking mode can only actually be written to the underlying resource when the application enters the event loop so that channel events can be processed. When a channel is in non-blocking mode, Tcl's internal buffers can hold an arbitrary amount of data, possibly consuming a large amount of memory. To avoid wasting memory, channels in non-blocking mode should normally be handled using \fBchan event\fR, where the application only invokes \fBchan puts\fR after being notified through a file event handler that the channel is ready for more output data. .PP Returns an error with POSIX error code \fBEILSEQ\fR if the encoding profile of \fIchannel\fR is \fBstrict\fR and the data cannot be encoded in the encoding for the channel. The data that were successfully encoded up to the point of error may be written to the channel. .RE .\" METHOD: read .TP \fBchan read \fIchannel\fR ?\fInumChars\fR? .TP \fBchan read \fR?\fB\-nonewline\fR? \fIchannel\fR . Reads and returns the next \fInumChars\fR characters from \fIchannel\fR. If \fInumChars\fR is omitted, all available characters up to the end of the file are read, or if \fIchannel\fR is in non-blocking mode, all currently-available characters are read. If there is an error on \fIchannel\fR, reading ceases and an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR may be given, causing any trailing line feed to be trimmed. .RS .PP If \fIchannel\fR is in non-blocking mode, fewer characters than requested may be returned. If \fIchannel\fR is configured to use a multi-byte encoding, bytes that do not form a complete character are retained in the buffers until enough bytes to complete the character accumulate, or the end of the data is reached. \fB\-nonewline\fR is ignored if characters are returned before reaching the end of the file. .PP Each end-of-line sequence according to the value of \fB\-translation\fR is translated into a line feed. .PP When reading from a serial port, most applications should configure the channel to be in non-blocking mode, but not necessarily use an event handler since most serial ports are comparatively slow. It is entirely possible to get a \fBreadable\fR event for each individual character. In blocking mode, \fBchan read\fR blocks forever when reading to the end of the data if there is no \fBchan configure -eofchar\fR configured for the channel. .PP If the encoding profile for \fIchannel\fR is \fBstrict\fR, raises an exception with the POSIX error code \fBEILSEQ\fR if a decoding error is encountered when reading. If \fIchannel\fR is blocking , advances the file pointer to the beginning of the invalid input and returns the error. The input that was successfully-decoded up to the first byte that resulted in an error is available in as the \fB\-result read\fR entry in the error option dictionary. If \fIchannel\fR is in non-blocking mode, returns the successfully-decoded input. A subsequent read starts at the position of the invalid data and raises a \fBEILSEQ\fR POSIX error exception. Unlike the blocking channel case, the \fB\-result read\fR key is not present in the error option dictionary. It may be possible to change the encoding for \fIchannel\fR in order to read the input that previously resulted in the decoding error. See \fBENCODING ERROR EXAMPLES\fR later. .RE .\" METHOD: seek .TP \fBchan seek \fIchannel offset\fR ?\fIorigin\fR? . Sets the current position in \fIchannel\fR to integer \fIoffset\fR bytes relative to \fIorigin\fR. A negative offset moves the current position backwards from the origin. \fIorigin\fR is one of the following: .RS .IP \fBstart\fR The origin is the start of the data. This is the default. .IP \fBcurrent\fR The origin is the current position. .IP \fBend\fR The origin is the end of the data. .PP \fBChan seek\fR flushes all buffered output even if \fIchannel\fR is in non-blocking mode, discards any buffered and unread input, and returns the empty string or an error if \fIchannel\fR does not support seeking. .PP \fIoffset\fR values are byte offsets, not character offsets. Unlike \fBchan read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, not characters, .RE .\" METHOD: tell .TP \fBchan tell \fIchannel\fR . Returns the offset in bytes of the current position in the underlying data, or -1 if \fIchannel\fR does not support seeking. The value can be passed to \fBchan seek\fR to set current position to that offset. .\" METHOD: truncate .TP \fBchan truncate \fIchannel\fR ?\fIlength\fR? . Flushes \fIchannel\fR and truncates the data in \fIchannel\fR to \fIlength\fR bytes, or to the current position in bytes if \fIlength\fR is omitted. . .SH EXAMPLES .SS "SIMPLE CHANNEL OPERATION EXAMPLES" .PP Instruct Tcl to always send output to \fBstdout\fR immediately, whether or not it is to a terminal: .PP |
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
chan puts "[incr lineNumber]: $line"
}
chan close $chan
.CE
.PP
In this example illustrating event driven reads,
\fBGetData\fR will be called with the channel as an
| | | > | | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
chan puts "[incr lineNumber]: $line"
}
chan close $chan
.CE
.PP
In this example illustrating event driven reads,
\fBGetData\fR will be called with the channel as an
argument whenever $chan becomes readable. The \fBread\fR call
reads whatever characters are currently available without blocking. Each
individual byte is interpreted as the corresponding Unicode character.
Here the channel has the fileevent removed when an end of file
occurs to avoid being continually called (see above). Alternatively
the channel may be closed on this condition.
.PP
.CS
proc GetData chan {
set data [chan read $chan]
chan puts "[string length $data] $data"
if {[chan eof $chan]} {
chan event $chan readable {}
}
}
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 | .CE .PP A network server that echoes its input line-by-line without preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... | | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
.CE
.PP
A network server that echoes its input line-by-line without
preventing servicing of other connections at the same time:
.PP
.CS
# This is a very simple logger...
proc log message {
\fBchan puts\fR stdout $message
}
# This is called whenever a new client connects to the server
proc connect {chan host port} {
set clientName [format <%s:%d> $host $port]
log "connection from $clientName"
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 |
lappend words {*}[join [scan $line %d%d%d]]
}
# Those words supply the size of the image and its
# overall depth per channel. Assign to variables.
lassign $words xSize ySize depth
| | | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
lappend words {*}[join [scan $line %d%d%d]]
}
# Those words supply the size of the image and its
# overall depth per channel. Assign to variables.
lassign $words xSize ySize depth
# Now switch to binary mode to read each byte as a character, where each
# character corresponds to one pixel (red,green, or blue).
\fBchan configure\fR $f -translation binary
set numDataBytes [expr {3 * $xSize * $ySize}]
set data [chan read $f $numDataBytes]
close $f
.CE
.SS "FILE SEEK EXAMPLES"
|
| ︙ | ︙ | |||
992 993 994 995 996 997 998 | # $data1 eq $data2 if the file wasn't updated .CE .PP Read the last 10 bytes from a file: .PP .CS set f [open file.data] | | > | | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 | # $data1 eq $data2 if the file wasn't updated .CE .PP Read the last 10 bytes from a file: .PP .CS set f [open file.data] # -translation binary guarantees no decoding errors since each possible value # of a byte corresponds to a character. Most other encodings could report a # decoding error. chan configure $f -translation binary \fBchan seek\fR $f -10 end set data [chan read $f 10] chan close $f .CE .PP Read a line from a file channel only if it starts with \fBfoobar\fR: |
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 | during channel input. First, creation of a test file containing the invalid UTF-8 sequence (\fBA \\xC3 B\fR): .PP .CS % set f [open test_A_195_B.txt wb]; chan puts -nonewline $f A\\xC3B; chan close $f .CE .PP | | | | | | | | | | | | | | 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 |
during channel input. First, creation of a test file containing
the invalid UTF-8 sequence (\fBA \\xC3 B\fR):
.PP
.CS
% set f [open test_A_195_B.txt wb]; chan puts -nonewline $f A\\xC3B; chan close $f
.CE
.PP
An attempt to read the file results in an encoding error which is
then introspected by switching the channel to binary mode. In the
example, when the error is reported the file position remains
unchanged so that the \fBchan gets\fR would later return the
full line if called.
.PP
.CS
% set f [open test_A_195_B.txt r]
file384b6a8
% chan configure $f -encoding utf-8 -profile strict
% catch {chan gets $f} e d
1
% set d
-code 1 -level 0
-errorstack {INNER {invokeStk1 gets file384b6a8}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
0
% chan configure $f -translation binary -profile strict
% chan gets $f
AÃB
.CE
.PP
The following example is similar to the above but demonstrates recovery after a
blocking read. The successfully decoded data "A" is returned in the error options
dictionary key \fB\-result read\fR. The file position is advanced on the encoding error
position 1. The data at the error position is thus recovered by the next
\fBchan read\fR command.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -profile strict -blocking 1
% catch {chan read $f} e d
1
% set d
-result {read A} -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
% chan tell $f
1
% chan configure $f -translation binary -profile strict
% chan read $f
ÃB
% chan close $f
.CE
.PP
Finally the same example, but this time with a non-blocking channel.
.PP
.CS
% set f [open test_A_195_B.txt r]
file35a65a0
% chan configure $f -encoding utf-8 -profile strict -blocking 0
% chan read $f
A
% chan tell $f
1
% catch {chan read $f} e d
1
% set d
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH class n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::class \- class of all classes | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH class n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::class \- class of all classes |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 2011-2015 Andreas Kupries '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH classvariable n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME classvariable \- create link from local variable to variable in class | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2011-2015 Andreas Kupries '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH classvariable n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME classvariable \- create link from local variable to variable in class |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times .SH "SYNOPSIS" .nf package require \fBTcl 8.5-\fR \fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? \fBclock clicks\fR ?\fI\-option\fR? \fBclock format\fI timeVal\fR ?\fI\-option value\fR...? \fBclock microseconds\fR \fBclock milliseconds\fR \fBclock scan\fI inputString\fR ?\fI\-option value\fR...? \fBclock seconds\fR .fi | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | '\" '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Copyright (c) 2024 Nathan Coulter. '\" .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times .SH "SYNOPSIS" .nf package require \fBTcl 8.5-\fR \fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? \fBclock classic\fR \fI...\fR \fBclock clicks\fR ?\fI\-option\fR? \fBclock format\fI timeVal\fR ?\fI\-option value\fR...? \fBclock microseconds\fR \fBclock milliseconds\fR \fBclock scan\fI inputString\fR ?\fI\-option value\fR...? \fBclock seconds\fR .fi |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | .TP \fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? . Adds a (possibly negative) offset to a time that is expressed as an integer number of seconds. See \fBCLOCK ARITHMETIC\fR for a full description. .\" METHOD: clicks .TP \fBclock clicks\fR ?\fI\-option\fR? . If no \fI\-option\fR argument is supplied, returns a high-resolution time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available on the system such as a CPU cycle counter. See \fBHIGH RESOLUTION TIMERS\fR for a full description. | > > > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | .TP \fBclock add\fI timeVal\fR ?\fIcount unit...\fR? ?\fI\-option value\fR? . Adds a (possibly negative) offset to a time that is expressed as an integer number of seconds. See \fBCLOCK ARITHMETIC\fR for a full description. .\" METHOD: clicks .TP \fBclock classic\fR \fI...\fR . See the documentation for clock in Tcl version 8.6. .TP \fBclock clicks\fR ?\fI\-option\fR? . If no \fI\-option\fR argument is supplied, returns a high-resolution time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available on the system such as a CPU cycle counter. See \fBHIGH RESOLUTION TIMERS\fR for a full description. |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | 1 January 1970, 00:00 UTC. Note that the count of seconds does not include any leap seconds; seconds are counted as if each UTC day has exactly 86400 seconds. Tcl responds to leap seconds by speeding or slowing its clock by a tiny fraction for some minutes until it is back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP | < < < < < < < < < | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | 1 January 1970, 00:00 UTC. Note that the count of seconds does not include any leap seconds; seconds are counted as if each UTC day has exactly 86400 seconds. Tcl responds to leap seconds by speeding or slowing its clock by a tiny fraction for some minutes until it is back in sync with UTC; its data model does not represent minutes that have 59 or 61 seconds. .TP \fIunit\fR . One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR, \fBdays\fR, \fBweekdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR. Used in conjunction with \fIcount\fR to identify an interval of time, for example, \fI3 seconds\fR or \fI1 year\fR. .SS "OPTIONS" |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | .TP \fB\-format\fR format . Specifies the desired output format for \fBclock format\fR or the expected input format for \fBclock scan\fR. The \fIformat\fR string consists of any number of characters other than the per-cent sign .PQ \fB%\fR | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | .TP \fB\-format\fR format . Specifies the desired output format for \fBclock format\fR or the expected input format for \fBclock scan\fR. The \fIformat\fR string consists of any number of characters other than the per-cent sign .PQ \fB%\fR interspersed with any number of \fIformat groups\fR, which are two-character sequences beginning with the per-cent sign. The permissible format groups, and their interpretation, are described under \fBFORMAT GROUPS\fR. .RS .PP On \fBclock format\fR, the default format is .PP .CS |
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | .IP [1] the environment variable \fBTCL_TZ\fR. .IP [2] the environment variable \fBTZ\fR. .IP [3] on Windows systems, the time zone settings from the Control Panel. .RE | < < < < < < < < < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | .IP [1] the environment variable \fBTCL_TZ\fR. .IP [2] the environment variable \fBTZ\fR. .IP [3] on Windows systems, the time zone settings from the Control Panel. .RE .PP If none of these is present, the C \fBlocaltime\fR and \fBmktime\fR functions are used to attempt to convert times between local and Greenwich. On 32-bit systems, this approach is likely to have bugs, particularly for times that lie outside the window (approximately the years 1902 to 2037) that can be represented in a 32-bit integer. .SH "CLOCK ARITHMETIC" |
| ︙ | ︙ | |||
427 428 429 430 431 432 433 | .PP The date is determined according to the fields that are present in the preprocessed format string. In order of preference: .IP [1] If the string contains a \fB%s\fR format group, representing seconds from the epoch, that group is used to determine the date. .IP [2] | | < | < < < | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 | .PP The date is determined according to the fields that are present in the preprocessed format string. In order of preference: .IP [1] If the string contains a \fB%s\fR format group, representing seconds from the epoch, that group is used to determine the date. .IP [2] If the string contains a \fB%J\fR format group, representing the Julian Day Number, that group is used to determine the date. .IP [3] If the string contains a complete set of format groups specifying century, year, month, and day of month; century, year, and day of year; or ISO8601 fiscal year, week of year, and day of week; those groups are combined and used to determine the date. If more than one complete set is present, the one at the rightmost position in the string is used. |
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | in the same day, once without and once with Daylight Saving Time. If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) .PP If the interpretation of the groups yields an impossible time because | < < | | 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | in the same day, once without and once with Daylight Saving Time. If this situation occurs, the first occurrence of the time is chosen. (For this reason, it is wise to have the input string contain the time zone when converting local times. This caveat does not apply to UTC times.) .PP If the interpretation of the groups yields an impossible time because a field is out of range, enough of that field's unit will be added to or subtracted from the time to bring it in range. Thus, if attempting to scan or format day 0 of the month, one day will be subtracted from day 1 of the month, yielding the last day of the previous month. .PP If the interpretation of the groups yields an impossible time because a Daylight Saving Time change skips over that time, or an ambiguous time because a Daylight Saving Time change skips back so that the clock |
| ︙ | ︙ | |||
572 573 574 575 576 577 578 | On output, produces the string \fBB.C.E.\fR or \fBC.E.\fR, or a string of the same meaning in the locale, to indicate whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. On input, accepts the string \fBB.C.E.\fR, \fBB.C.\fR, \fBC.E.\fR, \fBA.D.\fR, or the abbreviation appropriate to the current locale, and uses it to fix whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | On output, produces the string \fBB.C.E.\fR or \fBC.E.\fR, or a string of the same meaning in the locale, to indicate whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. On input, accepts the string \fBB.C.E.\fR, \fBB.C.\fR, \fBC.E.\fR, \fBA.D.\fR, or the abbreviation appropriate to the current locale, and uses it to fix whether \fB%Y\fR refers to years before or after Year 1 of the Common Era. .IP \fB%Ex\fR On output, produces a locale-dependent representation of the date in the locale's alternative calendar. On input, matches whatever \fB%Ex\fR produces. The locale's alternative calendar need not be the Gregorian calendar. .IP \fB%EX\fR On output, produces a locale-dependent representation of the |
| ︙ | ︙ | |||
638 639 640 641 642 643 644 | .IP \fB%I\fR On output, produces a two-digit number giving the hour of the day (12-11) on a 12-hour clock. On input, accepts such a number. .IP \fB%j\fR On output, produces a three-digit number giving the day of the year (001-366). On input, accepts such a number. .IP \fB%J\fR | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 | .IP \fB%I\fR On output, produces a two-digit number giving the hour of the day (12-11) on a 12-hour clock. On input, accepts such a number. .IP \fB%j\fR On output, produces a three-digit number giving the day of the year (001-366). On input, accepts such a number. .IP \fB%J\fR On output, produces a string of digits giving the Julian Day Number. On input, accepts a string of digits and interprets it as a Julian Day Number. The Julian Day Number is a count of the number of calendar days that have elapsed since 1 January, 4713 BCE of the proleptic Julian calendar. The epoch time of 1 January 1970 corresponds to Julian Day Number 2440588. .IP \fB%k\fR On output, produces a one- or two-digit number giving the hour of the day |
| ︙ | ︙ | |||
759 760 761 762 763 764 765 | accepts four digits and may be used to determine calendar date. Note that \fB%Y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%G\fR for that purpose. .IP \fB%z\fR On output, produces the current time zone, expressed in hours and minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to | | < < | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 | accepts four digits and may be used to determine calendar date. Note that \fB%Y\fR does not yield a year appropriate for use with the ISO8601 week number \fB%V\fR; programs should use \fB%G\fR for that purpose. .IP \fB%z\fR On output, produces the current time zone, expressed in hours and minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the time zone. .IP \fB%Z\fR On output, produces the current time zone's name, possibly translated to the given locale. On input, accepts a time zone specifier (see \fBTIME ZONES\fR below) that will be used to determine the time zone. This option should, in general, be used on input only when parsing RFC822 dates. Other uses are fraught with ambiguity; for instance, the string \fBBST\fR may represent British Summer Time or Brazilian Standard Time. It is recommended that date/time strings for use by computers use numeric time zones instead. .IP \fB%%\fR On output, produces a literal .QW \fB%\fR |
| ︙ | ︙ | |||
971 972 973 974 975 976 977 | Using that time as the base, day-of-week specifications are added. Next, relative specifications are used. If a date or day is specified, and no absolute or relative time is given, midnight is used. Finally, a correction is applied so that the correct hour of the day is produced after allowing for daylight savings time differences and the correct date is given when going from the end of a long month to a short month. | < < < < < < < < < < < < < < < < < < | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 | Using that time as the base, day-of-week specifications are added. Next, relative specifications are used. If a date or day is specified, and no absolute or relative time is given, midnight is used. Finally, a correction is applied so that the correct hour of the day is produced after allowing for daylight savings time differences and the correct date is given when going from the end of a long month to a short month. .SH "SEE ALSO" msgcat(n) .SH KEYWORDS clock, date, time .SH "COPYRIGHT" Copyright \(co 2004 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Local Variables: '\" mode: nroff '\" End: |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH close n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH concat n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH concat n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH configurable n 0.4 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH configurable n 0.4 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1993-1994 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. '\" .TH continue n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME continue \- Skip to the next iteration of a loop | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1993-1994 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH continue n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME continue \- Skip to the next iteration of a loop |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2014-2018 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "cookiejar" n 0.1 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cookiejar \- Implementation of the Tcl http package cookie jar protocol | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2014-2018 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "cookiejar" n 0.1 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cookiejar \- Implementation of the Tcl http package cookie jar protocol |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH copy n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::copy \- create copies of objects and classes | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH copy n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::copy \- create copies of objects and classes |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2009 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH coroutine n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values from coroutines | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2009 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH coroutine n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values from coroutines |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2001 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH dde n 1.4 dde "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME dde \- Execute a Dynamic Data Exchange command | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2001 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH dde n 1.4 dde "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME dde \- Execute a Dynamic Data Exchange command |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2007-2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH define n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::define, oo::objdefine, oo::Slot \- define and configure classes and objects | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2007-2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH define n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::define, oo::objdefine, oo::Slot \- define and configure classes and objects |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH dict n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME dict \- Manipulate dictionaries | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH dict n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME dict \- Manipulate dictionaries |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1998 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH encoding n "8.1" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME | > > > > > > > | | | > > > > > | | > > | > > > > > > | > | < > | > > > > > | < < | < < | | < | | < | < < | < | | | | | < < | < < | > < < | | | | < < | | < | > | | | < < < | | < < < < < < < < < < < < < < | < | | < > | < < > | < | | < | > | | | | | | | < > | | > | < < < < | < | | | < > | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 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 |
'\"
'\" Copyright (c) 1998 Scriptics Corporation.
'\" Copyright (c) 2023 Nathan Coulter
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" You may distribute and/or modify this program under the terms of the GNU
'\" Affero General Public License as published by the Free Software Foundation,
'\" either version 3 of the License, or (at your option) any later version.
'\"
'\" See the file "COPYING" for information on usage and redistribution.
'\"
.TH encoding n "8.1" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
.SH NAME
encoding \- Work with encodings
.SH SYNOPSIS
\fBencoding \fIoperation\fR ?\fIarg arg ...\fR?
.BE
.SH INTRODUCTION
.PP
In Tcl every string is composed of Unicode values. Text may be encoded into an
encoding such as cp1252, iso8859-1, Shitf\-JIS, utf-8, utf-16, etc. Not every
Unicode value is encodable in every encoding, and some encodings can encode
values that are not available in Unicode.
.PP
Even though Unicode is for encoding the written texts of human languages, any
sequence of bytes can be encoded as the first 255 Unicode values. In particular,
iso8859-1 is an encoding (a superset of classic ASCII) for a subset of Unicode
in which each byte is a Unicode value of 255
or less; any sequence of bytes can be considered to be a Unicode string
encoded in iso8859-1. To work with binary data in Tcl, decode it from
iso8859-1 when reading it in, and encode it into iso8859-1 when writing it out,
ensuring that each character in the string has a value of 255 or less.
Decoding such a string does nothing, and encoding encoding such a string also
does nothing.
.PP
For example, the following is true:
.CS
set text {In Tcl binary data is treated as Unicode text and it just works.}
set encoded [\fBencoding convertto\fR iso8859-1 $text]
expr {$text eq $encoded}; #-> 1
.CE
The following is also true:
.CS
set decoded [\fBencoding convertfrom\fR iso8859-1 $text]
expr {$text eq $decoded}; #-> 1
.CE
.SH DESCRIPTION
.PP
Performs one of the following encoding \fIoperations\fR:
.\" METHOD: convertfrom
.TP
\fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR
.TP
\fBencoding convertfrom\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR
.
Decodes \fIdata\fR encoded in \fIencoding\fR. If \fIencoding\fR is not
specified the current system encoding is used.
.VS "TCL8.7 TIP607, TIP656"
\fB\-profile\fR determines how invalid data for the encoding are handled. See
the \fBPROFILES\fR section below for details. Returns an error if decoding
fails. However, if \fB\-failindex\fR given, returns the result of the
conversion up to the point of termination, and stores in \fBvar\fR the index of
the character that could not be converted. If no errors are encountered the
entire result of the conversion is returned and the value \fB-1\fR is stored in
\fBvar\fR.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: convertto
.TP
\fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR
.TP
\fBencoding convertto\fR ?\fB\-profile \fIprofile\fR? ?\fB\-failindex var\fR? \fIencoding data\fR
.
Converts \fIstring\fR to \fIencoding\fR. If \fIencoding\fR is not given, the
current system encoding is used.
.VS "TCL8.7 TIP607, TIP656"
See \fBencoding convertfrom\fR for the meaning of \fB\-profile\fR and
\fB\-failindex\fR.
.VE "TCL8.7 TIP607, TIP656"
.\" METHOD: dirs
.TP
\fBencoding dirs\fR ?\fIdirectoryList\fR?
.
Sets the search path for \fB*.enc\fR encoding data files to the list of
directories given by \fIdirectoryList\fR. If \fIdirectoryList\fR is not given,
returns the current list of directories that make up the search path. It is
not an error for an item in \fIdirectoryList\fR to not refer to a readable,
searchable directory.
.\" METHOD: names
.TP
\fBencoding names\fR
.
Returns a list of the names of available encodings.
The encodings
.QW utf-8
and
.QW iso8859-1
are guaranteed to be present in the list.
.\" METHOD: profiles
.TP
\fBencoding profiles\fR
.VS "TCL8.7 TIP656"
Returns a list of names of available encoding profiles. See \fBPROFILES\fR
below.
.VE "TCL8.7 TIP656"
.\" METHOD: system
.TP
\fBencoding system\fR ?\fIencoding\fR?
.
Sets the system encoding to \fIencoding\fR. If \fIencoding\fR is not given,
returns the current system encoding. The system encoding is used to pass
strings to system calls.
.\" Do not put .VS on whole section as that messes up the bullet list alignment
.SH PROFILES
.PP
.VS "TCL8.7 TIP656"
Each \fIprofile\fR is a distinct strategy for dealing with invalid data for an
encoding.
.PP
The following profiles are currently implemented.
.VE "TCL8.7 TIP656"
.TP
\fBstrict\fR
.VS "TCL8.7 TIP656"
The default profile. The operation fails when invalid data for the encoding
are encountered.
.VE "TCL8.7 TIP656"
.TP
\fBtcl8\fR
.VS "TCL8.7 TIP656"
Provides for behaviour identical to that of Tcl 8.6: When
decoding, for encodings \fBother than utf-8\fR, each invalid byte is interpreted
as the Unicode value given by that one byte. For example, the byte 0x80, which
is invalid in the ASCII encoding would be mapped to the Unicode value U+0080.
For \fButf-8\fR, each invalid byte that is a valid CP1252 character is
interpreted as the Unicode value for that character, while each byte that is
not is treated as the Unicode value given by that one byte. For example, byte
0x80 is defined by CP1252 and is therefore mapped to its Unicode equivalent
U+20AC while byte 0x81 which is not defined by CP1252 is mapped to U+0081. As
an additional special case, the sequence 0xC0 0x80 is mapped to U+0000.
.RS
.PP
When encoding, each character that cannot be represented in the encoding is
replaced by an encoding-dependent character, usually the question mark \fB?\fR.
.RE
.VE "TCL8.7 TIP656"
.TP
\fBreplace\fR
.VS "TCL8.7 TIP 656"
When decoding, invalid bytes are replaced by U+FFFD, the Unicode REPLACEMENT
CHARACTER.
.RS
.PP
When encoding, Unicode values that cannot be represented in the target encoding
are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT
CHARACTER for UTF targets, and generally `?` for other encodings.
.RE
.VE "TCL8.7 TIP656"
.SH EXAMPLES
.PP
These examples use the utility proc below that prints the Unicode value for
each character in a string.
.PP
.CS
proc codepoints s {join [lmap c [split $s {}] {
string cat U+ [format %.6X [scan $c %c]]}]
}
.CE
.PP
Example 1: Convert from euc-jp:
.PP
.CS
% codepoints [\fBencoding convertfrom\fR euc-jp \exA4\exCF]
U+00306F
.CE
.PP
The result is the Unicode value
.QW "\eu306F" ,
which is the Hiragana letter HA.
.VS "TCL8.7 TIP607, TIP656"
.PP
Example 2: Error handling based on profiles:
.PP
The letter \fBA\fR is Unicode character U+0041 and the byte "\ex80" is invalid
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS | | | | 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 | % codepoints [\fBencoding convertfrom\fR -profile strict ascii A\ex80] unexpected byte sequence starting at index 1: '\ex80' .CE .PP Example 3: Get partial data and the error location: .PP .CS % codepoints [\fBencoding convertfrom\fR -failindex idx ascii AB\ex80] U+000041 U+000042 % set idx 2 .CE .PP Example 4: Encode a character that is not representable in ISO8859-1: .PP .CS % \fBencoding convertto\fR iso8859-1 A\eu0141 A? % \fBencoding convertto\fR -profile strict iso8859-1 A\eu0141 unexpected character at index 1: 'U+000141' % \fBencoding convertto\fR -failindex idx iso8859-1 A\eu0141 A % set idx 1 .CE .VE "TCL8.7 TIP607, TIP656" .PP .SH "SEE ALSO" Tcl_GetEncoding(3), fconfigure(n) .SH KEYWORDS encoding, unicode .\" Local Variables: .\" mode: nroff .\" End: |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH eof n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end of file condition on channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH error n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME error \- Generate an error | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH error n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME error \- Generate an error |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH eval n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eval \- Evaluate a Tcl script | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH eval n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eval \- Evaluate a Tcl script |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2006 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH exec n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exec \- Invoke subprocesses | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2006 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH exec n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exec \- Invoke subprocesses |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH exit n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exit \- End the application | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH exit n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exit \- End the application |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH expr n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH expr n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fcopy \- Copy data from one channel to another | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fcopy \- Copy data from one channel to another |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH file n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME file \- Manipulate file names and attributes | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH file n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME file \- Manipulate file names and attributes |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2008 Pat Thoyts '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2008 Pat Thoyts '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH filename n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME filename \- File name conventions supported by Tcl commands | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH filename n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME filename \- File name conventions supported by Tcl commands |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH flush n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH for n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME for \- 'For' loop | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH for n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME for \- 'For' loop |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH foreach n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME foreach \- Iterate over all elements in one or more lists | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH foreach n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME foreach \- Iterate over all elements in one or more lists |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH format n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME format \- Format a string in the style of sprintf | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH format n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME format \- Format a string in the style of sprintf |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" Copyright (c) 2019 Donal Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH fpclassify n 8.7 Tcl "Tcl Float Classifier" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fpclassify \- Floating point number classification of Tcl values | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2018 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" Copyright (c) 2019 Donal Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH fpclassify n 8.7 Tcl "Tcl Float Classifier" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fpclassify \- Floating point number classification of Tcl values |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH gets n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. .TH glob n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME glob \- Return names of files that match patterns .SH SYNOPSIS | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. .TH glob n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME glob \- Return names of files that match patterns .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH global n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME global \- Access global variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH global n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME global \- Access global variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH history n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME history \- Manipulate the history list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH history n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME history \- Manipulate the history list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-2000 Ajuba Solutions. '\" Copyright (c) 2004 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "http" n 2.10 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-2000 Ajuba Solutions. '\" Copyright (c) 2004 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "http" n 2.10 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2014-2018 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "idna" n 0.1 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::idna \- Support for normalization of Internationalized Domain Names | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2014-2018 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "idna" n 0.1 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::idna \- Support for normalization of Internationalized Domain Names |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH if n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME if \- Execute scripts conditionally | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH if n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME if \- Execute scripts conditionally |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH incr n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME incr \- Increment the value of a variable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH incr n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME incr \- Increment the value of a variable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions '\" Copyright (c) 2007-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. '\" .TH info n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME info \- Information about the state of the Tcl interpreter | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions '\" Copyright (c) 2007-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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH info n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME info \- Information about the state of the Tcl interpreter |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" Copyright (c) 2006-2008 Joe Mistachkin. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH interp n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME interp \- Create and manipulate Tcl interpreters | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" Copyright (c) 2004 Donal K. Fellows '\" Copyright (c) 2006-2008 Joe Mistachkin. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH interp n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME interp \- Create and manipulate Tcl interpreters |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH join n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME join \- Create a string by joining together list elements | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH join n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME join \- Create a string by joining together list elements |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lappend n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lappend n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lassign n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lassign \- Assign list elements to variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1992-1999 Karl Lehenbauer & Mark Diekhans '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lassign n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lassign \- Assign list elements to variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH ledit n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME ledit \- Replace elements of a list stored in variable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2022 Ashok P. Nadkarni <apnmbx-public@yahoo.com>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH ledit n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME ledit \- Replace elements of a list stored in variable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1991-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. '\" .TH library n "8.0" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, writeFile \- standard library of Tcl procedures .SH SYNOPSIS | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1991-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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH library n "8.0" Tcl "Tcl Built-In Commands" .so man.macros .BS .SH NAME auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, writeFile \- standard library of Tcl procedures .SH SYNOPSIS |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 2011-2015 Andreas Kupries '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH link n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME link \- create link from command to method of object | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 2011-2015 Andreas Kupries '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH link n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME link \- create link from command to method of object |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH linsert n 8.2 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME linsert \- Insert elements into a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH linsert n 8.2 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME linsert \- Insert elements into a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH list n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME list \- Create a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH list n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME list \- Create a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH llength n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME llength \- Count the number of elements in a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH llength n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME llength \- Count the number of elements in a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH lmap n "" Tcl "Tcl Built-In Commands" .so man.macros .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 | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lmap n "" Tcl "Tcl Built-In Commands" .so man.macros .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 |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH load n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH load n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2018 Peter Spjuth. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lpop n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lpop \- Get and remove an element in a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2018 Peter Spjuth. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lpop n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lpop \- Get and remove an element in a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2019 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lremove n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lremove \- Remove elements from a list by index | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2019 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lremove n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lremove \- Remove elements from a list by index |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2003 Simon Geard. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lrepeat n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrepeat \- Build a list by repeating elements | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2003 Simon Geard. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lrepeat n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrepeat \- Build a list by repeating elements |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreplace \- Replace elements in a list with new elements | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreplace \- Replace elements in a list with new elements |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2006 Donal K. Fellows. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lreverse n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreverse \- Reverse the order of a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2006 Donal K. Fellows. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lreverse n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreverse \- Reverse the order of a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Copyright (c) 2003-2004 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lsearch n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsearch \- See if a list contains a particular element | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" Copyright (c) 2003-2004 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lsearch n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsearch \- See if a list contains a particular element |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2022 Eric Taylor. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lseq n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lseq \- Build a numeric sequence returned as a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2022 Eric Taylor. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lseq n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lseq \- Build a numeric sequence returned as a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lset \- Change an element in a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lset \- Change an element in a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH lsort n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny <kennykb@acm.org>. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH lsort n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathfunc \- Mathematical functions for Tcl expressions | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" Copyright (c) 2005 Kevin B. Kenny <kennykb@acm.org>. All rights reserved '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME mathfunc \- Mathematical functions for Tcl expressions |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME my, myclass \- invoke any method of current object or its class | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME my, myclass \- invoke any method of current object or its class |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" Copyright (c) 2004-2005 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" Copyright (c) 2004-2005 Donal K. Fellows. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH namespace n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH next n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH next n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME next, nextto \- invoke superclass method implementations |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2007-2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH object n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::object \- root class of the class hierarchy | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2007-2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH object n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::object \- root class of the class hierarchy |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH open n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME open \- Open a file-based or command pipeline channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH open n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME open \- Open a file-based or command pipeline channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH package n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME package \- Facilities for package loading and version control | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH package n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME package \- Facilities for package loading and version control |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH pid n 7.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pid \- Retrieve process identifiers | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH pid n 7.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pid \- Retrieve process identifiers |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2006 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "platform" n 1.0.4 platform "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform \- System identification support code and utilities | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2006 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "platform" n 1.0.4 platform "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform \- System identification support code and utilities |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2006-2008 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform::shell \- System identification support code and utilities | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2006-2008 ActiveState Software Inc '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME platform::shell \- System identification support code and utilities |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2008 Peter Spjuth <pspjuth@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH prefix n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::prefix \- facilities for prefix matching | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2008 Peter Spjuth <pspjuth@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH prefix n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::prefix \- facilities for prefix matching |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH proc n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME proc \- Create a Tcl procedure | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH proc n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME proc \- Create a Tcl procedure |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2017 Frederic Bonnet. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH process n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::process \- Subprocess management | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2017 Frederic Bonnet. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH process n 8.7 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcl::process \- Subprocess management |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH puts n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH pwd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pwd \- Return the absolute path of the current working directory | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH pwd n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pwd \- Return the absolute path of the current working directory |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" 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 re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions .BE | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions .BE |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH read n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH refchan n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH refchan n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME refchan \- command handler API of reflected channels |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH registry n 1.1 registry "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH registry n 1.1 registry "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH regsub n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH regsub n 8.3 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH rename n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME rename \- Rename or delete a command | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH rename n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME rename \- Rename or delete a command |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH return n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME return \- Return from a procedure, or set return code of a script | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2003. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH return n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME return \- Return from a procedure, or set return code of a script |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME safe \- Creating and manipulating safe interpreters |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH scan n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME scan \- Parse string using conversion specifiers in the style of sscanf | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH scan n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME scan \- Parse string using conversion specifiers in the style of sscanf |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH seek n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH self n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME self \- method call internal introspection | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH self n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME self \- method call internal introspection |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH set n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME set \- Read and write variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH set n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME set \- Read and write variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH singleton n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::singleton \- a class that does only allows one instance of itself | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2018 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH singleton n 0.3 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME oo::singleton \- a class that does only allows one instance of itself |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH socket n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME socket \- Open a TCP network connection | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH socket n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME socket \- Open a TCP network connection |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH source n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME source \- Evaluate a file or resource as a Tcl script | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH source n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME source \- Evaluate a file or resource as a Tcl script |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH split n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME split \- Split a string into a proper Tcl list | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH split n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME split \- Split a string into a proper Tcl list |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" 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. '\" .TH subst n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME subst \- Perform backslash, command, and variable substitutions | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH subst n 7.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME subst \- Perform backslash, command, and variable substitutions |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH switch n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH switch n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH tailcall n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tailcall \- Replace the current procedure with another command | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH tailcall n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tailcall \- Replace the current procedure with another command |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcltest \- Test harness support code and utilities | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcltest \- Test harness support code and utilities |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH tell n 8.1 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH throw n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME throw \- Generate a machine-readable error | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH throw n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME throw \- Generate a machine-readable error |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH time n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME time \- Time the execution of a script | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH time n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME time \- Time the execution of a script |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2005 Sergey Brester aka sebres. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH timerate n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME timerate \- Calibrated performance measurements of script execution time | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2005 Sergey Brester aka sebres. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH timerate n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME timerate \- Calibrated performance measurements of script execution time |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2004-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH tm n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tm \- Facilities for locating and loading of Tcl Modules | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2004-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH tm n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tm \- Facilities for locating and loading of Tcl Modules |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 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. '\" .TH trace n "8.4" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME trace \- Monitor variable accesses, command usages and command executions | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH trace n "8.4" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME trace \- Monitor variable accesses, command usages and command executions |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH transchan n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH transchan n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME transchan \- command handler API of channel transforms |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH try n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME try \- Trap and process errors and exceptions | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH try n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME try \- Trap and process errors and exceptions |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH unknown n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unknown \- Handle attempts to use non-existent commands | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH unknown n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unknown \- Handle attempts to use non-existent commands |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 2003 George Petasis <petasis@iit.demokritos.gr>. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH unload n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unload \- Unload machine code | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 2003 George Petasis <petasis@iit.demokritos.gr>. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH unload n 8.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unload \- Unload machine code |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 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. '\" .TH unset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH unset n 8.4 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1990-1992 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. '\" .TH update n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME update \- Process pending events and idle callbacks | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1990-1992 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH update n 7.5 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME update \- Process pending events and idle callbacks |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH uplevel n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME uplevel \- Execute a script in a different stack frame | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH uplevel n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME uplevel \- Execute a script in a different stack frame |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH upvar n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH upvar n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" 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. '\" .TH variable n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME variable \- create and initialize a namespace variable | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH variable n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME variable \- create and initialize a namespace variable |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH vwait n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME vwait \- Process events until a variable is written | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH vwait n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME vwait \- Process events until a variable is written |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 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. '\" .TH while n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME while \- Execute script repeatedly as long as a condition is met | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH while n "" Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME while \- Execute script repeatedly as long as a condition is met |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com> '\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de> '\" Copyright (c) 2015 Sean Woods <yoda@etoyoc.com> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH zipfs n 1.0 Zipfs "zipfs Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zipfs \- Mount and work with ZIP files within Tcl | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 2015 Jan Nijtmans <jan.nijtmans@gmail.com> '\" Copyright (c) 2015 Christian Werner <chw@ch-werner.de> '\" Copyright (c) 2015 Sean Woods <yoda@etoyoc.com> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH zipfs n 1.0 Zipfs "zipfs Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zipfs \- Mount and work with ZIP files within Tcl |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" 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. '\" .TH zlib n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zlib \- compression and decompression operations | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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. '\" '\" You may distribute and/or modify this program under the terms of the GNU '\" Affero General Public License as published by the Free Software Foundation, '\" either version 3 of the License, or (at your option) any later version. '\" '\" See the file "COPYING" for information on usage and redistribution. '\" .TH zlib n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME zlib \- compression and decompression operations |
| ︙ | ︙ |
1 | /* | < < < | 1 2 3 4 5 6 7 8 | /* * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 | * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * Note that there are some incestuous relationships between this code and NFA * arc maintenance, which perhaps ought to be cleaned up sometime. */ #define CISERR() VISERR(cm->v) #define CERR(e) VERR(cm->v, (e)) /* - initcm - set up new colormap ^ static void initcm(struct vars *, struct colormap *); */ | > > > > > > > > > > > > > > > | 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 | * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * Note that there are some incestuous relationships between this code and NFA * arc maintenance, which perhaps ought to be cleaned up sometime. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * colorings of characters * This file is #included by regcomp.c. * */ #define CISERR() VISERR(cm->v) #define CERR(e) VERR(cm->v, (e)) /* - initcm - set up new colormap ^ static void initcm(struct vars *, struct colormap *); */ |
| ︙ | ︙ |
1 | /* | < < < | 1 2 3 4 5 6 7 8 | /* * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * Notes: * Only (selected) functions in _this_ file should treat chr* as non-constant. */ /* | > > > > > > > > > > > > > > > | 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 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Utility functions for handling cvecs * This file is #included by regcomp.c. * */ /* * Notes: * Only (selected) functions in _this_ file should treat chr* as non-constant. */ /* |
| ︙ | ︙ |
1 | /* | < < < | 1 2 3 4 5 6 7 8 | /* * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* scanning macros (know about v) */ #define ATEOS() (v->now >= v->stop) #define HAVE(n) (v->stop - v->now >= (n)) #define NEXT1(c) (!ATEOS() && *v->now == CHR(c)) #define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b)) #define NEXT3(a,b,c) \ | > > > > > > > > > > > > > > > | 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 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * lexical analyzer * This file is #included by regcomp.c. * */ /* scanning macros (know about v) */ #define ATEOS() (v->now >= v->stop) #define HAVE(n) (v->stop - v->now >= (n)) #define NEXT1(c) (!ATEOS() && *v->now == CHR(c)) #define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b)) #define NEXT3(a,b,c) \ |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
/*
* regc_locale.c --
*
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
* Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/* ASCII character-name table */
static const struct cname {
const char *name;
const char code;
} cnames[] = {
| > > > > > > > > > | 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 |
/*
* regc_locale.c --
*
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
* Copyright © 1998 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/* ASCII character-name table */
static const struct cname {
const char *name;
const char code;
} cnames[] = {
|
| ︙ | ︙ |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | * 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. * * One or two things that technically ought to be in here are actually in * color.c, thanks to some incestuous relationships in the color chains. */ #define NISERR() VISERR(nfa->v) #define NERR(e) VERR(nfa->v, (e)) #define STACK_TOO_DEEP(x) (0) #define CANCEL_REQUESTED(x) (0) #define REG_CANCEL 777 | > > > > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * 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. * * One or two things that technically ought to be in here are actually in * color.c, thanks to some incestuous relationships in the color chains. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #define NISERR() VISERR(nfa->v) #define NERR(e) VERR(nfa->v, (e)) #define STACK_TOO_DEEP(x) (0) #define CANCEL_REQUESTED(x) (0) #define REG_CANCEL 777 |
| ︙ | ︙ |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ #include "regguts.h" /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ | > > > > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "regguts.h" /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ |
| ︙ | ︙ |
| ︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * Headers if any. */ #include "regex.h" | > > > > > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Headers if any. */ #include "regex.h" |
| ︙ | ︙ |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ /* - longest - longest-preferred matching engine ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *); */ static chr * /* endpoint, or NULL */ longest( | > > > > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* - longest - longest-preferred matching engine ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *, int *); */ static chr * /* endpoint, or NULL */ longest( |
| ︙ | ︙ |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ #include "regguts.h" /* * Unknown-error explanation. */ | > > > > > > > > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "regguts.h" /* * Unknown-error explanation. */ |
| ︙ | ︙ |
1 2 3 4 5 6 | #ifndef _REGEX_H_ #define _REGEX_H_ /* never again */ #include "tclInt.h" /* | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 | #ifndef _REGEX_H_ #define _REGEX_H_ /* never again */ #include "tclInt.h" /* * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * * Prototypes etc. marked with "^" within comments get gathered up (and * possibly edited) by the regfwd program and inserted near the bottom of this * file. * * We offer the option of declaring one wide-character version of the RE | > > > > > > > > > > > > | 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 | * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * * regular expressions * * * Prototypes etc. marked with "^" within comments get gathered up (and * possibly edited) by the regfwd program and inserted near the bottom of this * file. * * We offer the option of declaring one wide-character version of the RE |
| ︙ | ︙ |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "regguts.h" /* * Lazy-DFA representation. */ | > > > > > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "regguts.h" /* * Lazy-DFA representation. */ |
| ︙ | ︙ |
1 | /* | < < | 1 2 3 4 5 6 7 8 | /* * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | * * You might think that this could be incorporated into regcomp.c, and that * would be a reasonable idea... except that this is a generic function (with * a generic name), applicable to all compiled REs regardless of the size of * their characters, whereas the stuff in regcomp.c gets compiled once per * character size. */ #include "regguts.h" /* - regfree - free an RE (generic function, punts to RE-specific function) * * Ignoring invocation with NULL is a convenience. | > > > > > > > > > > > > > > | 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 | * * You might think that this could be incorporated into regcomp.c, and that * would be a reasonable idea... except that this is a generic function (with * a generic name), applicable to all compiled REs regardless of the size of * their characters, whereas the stuff in regcomp.c gets compiled once per * character size. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * regfree - free an RE * */ #include "regguts.h" /* - regfree - free an RE (generic function, punts to RE-specific function) * * Ignoring invocation with NULL is a convenience. |
| ︙ | ︙ |
1 | /* | < < < < < | 1 2 3 4 5 6 7 8 | /* * Copyright © 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "regguts.h" /* - regcomp - compile regular expression */ int | > > > > > > > > > > > > > > > > > | 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 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * regcomp and regexec - front ends to re_ routines * * Mostly for implementation of backward-compatibility kludges. Note that * these routines exist ONLY in char versions. * */ #include "regguts.h" /* - regcomp - compile regular expression */ int |
| ︙ | ︙ |
1 | /* | < < | 1 2 3 4 5 6 7 8 | /* * Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics * Corporation, none of whom are responsible for the results. The author * thanks all of them. * |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * Environmental customization. It should not (I hope) be necessary to alter * the file you are now reading -- regcustom.h should handle it all, given * care here and elsewhere. */ #include "regcustom.h" | > > > > > > > > > > > > > > | 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 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Internal interface definitions, etc., for the reg package * */ /* * Environmental customization. It should not (I hope) be necessary to alter * the file you are now reading -- regcustom.h should handle it all, given * care here and elsewhere. */ #include "regcustom.h" |
| ︙ | ︙ |
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved.
# Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
library tcl
# Define the tcl interface with several sub interfaces:
# tclPlat - platform specific public
# tclInt - generic private
# tclPlatInt - platform specific private
interface tcl
hooks {tclPlat tclInt tclIntPlat}
scspec EXTERN
| > > > > > > > | < | > | 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 |
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved.
# Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
library tcl
# Define the tcl interface with several sub interfaces:
# tclPlat - platform specific public
# tclInt - generic private
# tclPlatInt - platform specific private
interface tcl
hooks {tclPlat tclInt tclIntPlat}
scspec EXTERN
# Declare each of the functions in the public Tcl interface. In order to
# preserve backwards compatibility, an index should never be reused for a
# different function.
declare 0 {
int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name,
const char *version, const void *clientData)
}
declare 1 {
const char *Tcl_PkgRequireEx(Tcl_Interp *interp,
|
| ︙ | ︙ | |||
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 |
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
Tcl_Size numBytes, const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length,
const char *file, int line)
}
| > > > > > > > > | 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 |
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
# Removed in 9.0 (changed to macro):
#declare 22 {
# Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line)
#}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes,
Tcl_Size numBytes, const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv,
const char *file, int line)
}
# Removed in 9.0 (changed to macro):
#declare 26 {
# Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
#}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length,
const char *file, int line)
}
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 {
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 {
const Tcl_ObjType *Tcl_GetObjType(const char *typeName)
}
| > > > > > | | < > > | | | < > > | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
# Removed in 9.0, replaced by macro.
#declare 36 {
# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
# const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
#}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 {
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 {
const Tcl_ObjType *Tcl_GetObjType(const char *typeName)
}
#declare 41 {
# char *TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr)
#}
declare 42 {
void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
declare 43 {
int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *elemListPtr)
}
declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
#obsolete in 9.0
#declare 45 {
# int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
# void *objcPtr, Tcl_Obj ***objvPtr)
#}
declare 46 {
int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr)
}
#obsolete in 9.0
#declare 47 {
# int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
# void *lengthPtr)
#}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first,
Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 49 {
# Tcl_Obj *Tcl_NewBooleanObj(int intValue)
#}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
# Removed in 9.0 (changed to macro):
#declare 52 {
# Tcl_Obj *Tcl_NewIntObj(int intValue)
#}
declare 53 {
Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 54 {
# Tcl_Obj *Tcl_NewLongObj(long longValue)
#}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length)
}
# Removed in 9.0 (changed to macro):
#declare 57 {
# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue)
#}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
Tcl_Size numBytes)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
# Removed in 9.0 (changed to macro):
#declare 61 {
# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
#}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[])
}
# Removed in 9.0 (changed to macro):
#declare 63 {
# void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
#}
declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length)
}
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length)
}
# Removed in 9.0, replaced by macro.
#declare 66 {
# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
#}
# Removed in 9.0, replaced by macro.
#declare 67 {
# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
# Tcl_Size length)
#}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 {
void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
declare 70 {
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
| > > > > > > > > | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
# Removed in 9.0
#declare 76 {
# void Tcl_BackgroundError(Tcl_Interp *interp)
#}
# Removed in 9.0:
#declare 77 {
# char Tcl_Backslash(const char *src, int *readPtr)
#}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
void *clientData)
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
| > > > > > > | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
# Removed in 9.0:
#declare 95 {
# void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
# int numArgs, Tcl_ValueType *argTypes,
# Tcl_MathProc *proc, void *clientData)
#}
declare 96 {
Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
const char *cmdName,
Tcl_ObjCmdProc *proc, void *clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 {
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 132 {
void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
}
declare 134 {
| > > > > > > > > | 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 |
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
# Removed in 9.0, replaced by macro.
#declare 129 {
# int Tcl_Eval(Tcl_Interp *interp, const char *script)
#}
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
# Removed in 9.0, replaced by macro.
#declare 131 {
# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
#}
declare 132 {
void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
}
declare 134 {
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 149 {
int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 150 {
void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
| > > > > > | 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 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
# Removed in 9.0 (stub entry only)
#declare 144 {
# const char *Tcl_FindExecutable(const char *argv0)
#}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
declare 146 {
int Tcl_Flush(Tcl_Channel chan)
}
declare 149 {
int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 150 {
void *Tcl_GetAssocData(Tcl_Interp *interp, const char *name,
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 179 {
int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
const char *hiddenCmdToken)
}
declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
| > > > > > > > > > > > > > > > > > | 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 |
}
declare 172 {
Tcl_Interp *Tcl_GetChild(Tcl_Interp *interp, const char *name)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
# Removed in 9.0, replaced by macro.
#declare 174 {
# const char *Tcl_GetStringResult(Tcl_Interp *interp)
#}
# Removed in 9.0, replaced by macro.
#declare 175 {
# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
# int flags)
#}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
# Removed in 9.0, replaced by macro.
#declare 177 {
# int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
#}
# Removed in 9.0, replaced by macro.
#declare 178 {
# int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
#}
declare 179 {
int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
const char *hiddenCmdToken)
}
declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
char *Tcl_Merge(Tcl_Size argc, const char *const *argv)
}
declare 193 {
| > > > > | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
# Removed in 9.0
#declare 190 {
# int Tcl_MakeSafe(Tcl_Interp *interp)
#}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
declare 192 {
char *Tcl_Merge(Tcl_Size argc, const char *const *argv)
}
declare 193 {
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
}
declare 218 {
Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
declare 221 {
int Tcl_ServiceAll(void)
}
declare 222 {
int Tcl_ServiceEvent(int flags)
}
declare 223 {
| > > > > | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
}
declare 218 {
Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr)
}
# Removed in 9.0:
#declare 220 {
# int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
#}
declare 221 {
int Tcl_ServiceAll(void)
}
declare 222 {
int Tcl_ServiceEvent(int flags)
}
declare 223 {
|
| ︙ | ︙ | |||
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 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
declare 231 {
Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth)
}
declare 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 238 {
const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
const char *Tcl_SignalId(int sig)
}
| > > > > > > > > > > > > > > | 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 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
# Removed in 9.0 (stub entry only)
#declare 230 {
# const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
#}
declare 231 {
Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth)
}
# Removed in 9.0, replaced by macro.
#declare 232 {
# void Tcl_SetResult(Tcl_Interp *interp, char *result,
# Tcl_FreeProc *freeProc)
#}
declare 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
# Removed in 9.0, replaced by macro.
#declare 237 {
# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
# const char *newValue, int flags)
#}
declare 238 {
const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
const char *Tcl_SignalId(int sig)
}
|
| ︙ | ︙ | |||
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 |
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 262 {
void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
void *prevClientData)
}
declare 263 {
Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
declare 272 {
const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 |
int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr)
}
# Removed in 9.0 (stub entry only)
#declare 244 {
# void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix,
# Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
#}
# Removed in 9.0 (stub entry only)
#declare 245 {
# int Tcl_StringMatch(const char *str, const char *pattern)
#}
# Removed in 9.0:
#declare 246 {
# int Tcl_TellOld(Tcl_Channel chan)
#}
# Removed in 9.0, replaced by macro.
#declare 247 {
# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, void *clientData)
#}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, void *clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
# Removed in 9.0, replaced by macro.
#declare 253 {
# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
#}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
# Removed in 9.0, replaced by macro.
#declare 255 {
# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
# Tcl_VarTraceProc *proc, void *clientData)
#}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
void *clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
# Removed in 9.0, replaced by macro.
#declare 258 {
# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
# const char *varName, const char *localName, int flags)
#}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
# Removed in 9.0, replaced by macro.
#declare 261 {
# void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
# int flags, Tcl_VarTraceProc *procPtr, void *prevClientData)
#}
declare 262 {
void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
void *prevClientData)
}
declare 263 {
Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
# Removed in 9.0:
#declare 267 {
# void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
#}
# Removed in 9.0:
#declare 268 {
# void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
#}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
# Removed in 9.0, replaced by macro.
#declare 271 {
# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
# const char *version, int exact)
#}
declare 272 {
const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
# Removed in 9.0, replaced by macro.
#declare 273 {
# int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
# const char *version)
#}
# TIP #268: The internally used new Require function is in slot 573.
# Removed in 9.0, replaced by macro.
#declare 274 {
# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
# const char *version, int exact)
#}
# Removed in 9.0:
#declare 275 {
# void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
#}
# Removed in 9.0:
#declare 276 {
# int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
#}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
# Removed in 9.0:
#declare 278 {
# TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
#}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
| > > > > | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData)
}
# Removed in 9.0
#declare 290 {
# void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
#}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[],
int flags)
|
| ︙ | ︙ | |||
971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
declare 312 {
Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
Tcl_Size charsToRead, int appendFlag)
}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
| > > > > > > > > | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
declare 312 {
Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length)
}
declare 313 {
Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
Tcl_Size charsToRead, int appendFlag)
}
# Removed in 9.0
#declare 314 {
# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
#}
# Removed in 9.0
#declare 315 {
# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
#}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
}
declare 339 {
Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
declare 343 {
void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
| > > > > > > > > | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 |
}
declare 339 {
Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
# Removed in 9.0:
#declare 341 {
# const char *Tcl_GetDefaultEncodingDir(void)
#}
# Removed in 9.0:
#declare 342 {
# void Tcl_SetDefaultEncodingDir(const char *path)
#}
declare 343 {
void Tcl_AlertNotifier(void *clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
|
| ︙ | ︙ | |||
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 |
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
declare 354 {
char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
Tcl_Size uniLength, Tcl_DString *dsPtr)
}
declare 355 {
unsigned short *Tcl_UtfToChar16DString(const char *src,
Tcl_Size length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, Tcl_Size length)
}
| > > > > > > > > > > | 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 |
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {
Tcl_Size Tcl_Char16Len(const unsigned short *uniStr)
}
# Removed in 9.0:
#declare 353 {
# int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
# unsigned long numChars)
#}
declare 354 {
char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
Tcl_Size uniLength, Tcl_DString *dsPtr)
}
declare 355 {
unsigned short *Tcl_UtfToChar16DString(const char *src,
Tcl_Size length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
# Removed in 9.0:
#declare 357 {
# Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
# Tcl_Size count)
#}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, Tcl_Size length)
}
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
}
declare 380 {
Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
declare 383 {
Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
}
declare 384 {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
Tcl_Size length)
}
| > > > > | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 |
}
declare 380 {
Tcl_Size TclGetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
# Removed in 9.0, replaced by macro.
#declare 382 {
# Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
#}
declare 383 {
Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last)
}
declare 384 {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
Tcl_Size length)
}
|
| ︙ | ︙ | |||
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 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr)
}
declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 407 {
Tcl_DriverGetOptionProc *Tcl_ChannelGetOptionProc(
const Tcl_ChannelType *chanTypePtr)
| > > > > > > > > > > | 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 |
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
# Removed in 9.0
#declare 401 {
# Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
# const Tcl_ChannelType *chanTypePtr)
#}
declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr)
}
declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
# Removed in 9.0
#declare 405 {
# Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
# const Tcl_ChannelType *chanTypePtr)
#}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 407 {
Tcl_DriverGetOptionProc *Tcl_ChannelGetOptionProc(
const Tcl_ChannelType *chanTypePtr)
|
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
| > > > > > > > > > > > > > > > > > > > | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
# Removed in 9.0:
#declare 419 {
# int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
# unsigned long numChars)
#}
# Removed in 9.0:
#declare 420 {
# int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
# const Tcl_UniChar *uniPattern, int nocase)
#}
# Removed in 9.0, as it is actually a macro:
#declare 421 {
# Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key)
#}
# Removed in 9.0, as it is actually a macro:
#declare 422 {
# Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
# const void *key, int *newPtr)
#}
declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
# TIP#36 (better access to 'subst') dkf
declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
| > > > > > > > > > > > > | 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 |
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr)
}
# TIP#15 (math function introspection) dkf
# Removed in 9.0:
#declare 435 {
# int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
# int *numArgsPtr, Tcl_ValueType **argTypesPtr,
# Tcl_MathProc **procPtr, void **clientDataPtr)
#}
# Removed in 9.0:
#declare 436 {
# Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
#}
# TIP#36 (better access to 'subst') dkf
declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
|
| ︙ | ︙ | |||
1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
}
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
| > > > > > | 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 |
}
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
# Removed in 9.0 (stub entry only)
#declare 519 {nostub {Don't use this function in a stub-enabled extension}} {
# Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
#}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, void *clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
|
| ︙ | ︙ | |||
2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 |
}
declare 655 {
const char *Tcl_UtfNext(const char *src)
}
declare 656 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
# TIP 656
declare 658 {
int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
Tcl_Size *errorLocationPtr)
}
| > > > > > | 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 |
}
declare 655 {
const char *Tcl_UtfNext(const char *src)
}
declare 656 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
# Removed by TIP #652
#
#declare 657 {
# int Tcl_UniCharIsUnicode(int ch)
#}
# TIP 656
declare 658 {
int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr,
Tcl_Size *errorLocationPtr)
}
|
| ︙ | ︙ | |||
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 |
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
declare 690 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Mac OS X specific functions
declare 1 {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
}
# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
declare 690 {
void TclUnusedStubEntry(void)
}
declare 691 {
Tcl_ObjInterface *Tcl_NewObjInterface(void)
}
declare 692 {
Tcl_ObjType *Tcl_NewObjType(void)
}
declare 693 {
int Tcl_ObjInterfaceSetVersion(Tcl_ObjInterface *oiPtr ,int version)
}
declare 694 {
int Tcl_ObjTypeSetFreeInternalRepProc(Tcl_ObjType *otPtr
, Tcl_FreeInternalRepProc *freeIntRepProc)
}
declare 695 {
int Tcl_ObjTypeSetDupInternalRepProc(Tcl_ObjType *otPtr
,Tcl_DupInternalRepProc *dupIntRepProc)
}
declare 696 {
int Tcl_ObjTypeSetUpdateStringProc(Tcl_ObjType *otPtr
,Tcl_UpdateStringProc *updateStringProc)
}
declare 697 {
int Tcl_ObjTypeSetSetFromAnyProc(Tcl_ObjType *otPtr
,Tcl_SetFromAnyProc *setFromAnyProc)
}
declare 698 {
int Tcl_ObjTypeSetVersion(Tcl_ObjType *otPtr ,int version)
}
declare 699 {
int Tcl_ObjInterfaceSetFnListAll(Tcl_ObjInterface *oiPtr
, Tcl_ObjInterfaceListAllProc *fnPtr)
}
declare 700 {
int Tcl_ObjInterfaceSetFnListAppend(Tcl_ObjInterface *oiPtr
, Tcl_ObjInterfaceListAppendProc *fnPtr)
}
declare 701 {
int Tcl_ObjInterfaceSetFnListAppendList(Tcl_ObjInterface *oiPtr
, Tcl_ObjInterfaceListAppendlistProc fnPtr)
}
declare 702 {
int Tcl_ObjInterfaceSetFnListIndex(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListIndexProc fnPtr)
}
declare 703 {
int Tcl_ObjInterfaceSetFnListIndexEnd(Tcl_ObjInterface *oiPtr
, Tcl_ObjInterfaceListIndexEndProc fnPtr)
}
declare 704 {
int Tcl_ObjInterfaceSetFnListIsSorted(Tcl_ObjInterface *oiPtr
, Tcl_ObjInterfaceListIsSortedProc fnPtr)
}
declare 705 {
int Tcl_ObjInterfaceSetFnListLength(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListLengthProc fnPtr)
}
declare 706 {
int Tcl_ObjInterfaceSetFnListRange(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListRangeProc fnPtr)
}
declare 707 {
int Tcl_ObjInterfaceSetFnListRangeEnd(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListRangeEndProc fnPtr)
}
declare 708 {
int Tcl_ObjInterfaceSetFnListReplace(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListReplaceProc fnPtr)
}
declare 709 {
int Tcl_ObjInterfaceSetFnListReplaceList(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListReplaceListProc fnPtr)
}
declare 710 {
int Tcl_ObjInterfaceSetFnListReverse(Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListReverseProc fnPtr)
}
declare 711 {
int Tcl_ObjInterfaceSetFnListSet(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListSetProc fnPtr)
}
declare 712 {
int Tcl_ObjInterfaceSetFnListSetDeep(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListSetDeepProc fnPtr)
}
declare 713 {
int Tcl_ObjInterfaceSetFnStringIndex(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringIndexProc fnPtr)
}
declare 714 {
int Tcl_ObjInterfaceSetFnStringIndexEnd(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringIndexEndProc fnPtr)
}
declare 715 {
int Tcl_ObjInterfaceSetFnStringLength(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringLengthProc fnPtr)
}
declare 716 {
int Tcl_ObjInterfaceSetFnStringRange(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringRangeProc fnPtr)
}
declare 717 {
int Tcl_ObjInterfaceSetFnStringRangeEnd(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringRangeEndProc fnPtr)
}
declare 718 {
int Tcl_ObjTypeSetInterface(Tcl_ObjType *objTypePtr
,Tcl_ObjInterface *objInterfacePtr)
}
declare 719 {
int Tcl_ObjTypeSetName(Tcl_ObjType *objTypePtr ,char *name)
}
declare 720 {
int Tcl_ObjInterfaceSetFnStringIsEmpty(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceStringIsEmptyProc fnPtr)
}
declare 721 {
int Tcl_ObjInterfaceSetFnListContains(Tcl_ObjInterface *oiPtr
,Tcl_ObjInterfaceListContainsProc fnPtr)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
# available on the designated platform.
interface tclPlat
################################
# Unix specific functions
# (none)
################################
# Mac OS X specific functions
declare 1 {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
Tcl_Size hasResourceFile, Tcl_Size maxPathLen, char *libraryPath)
}
declare 2 {
void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
################################
# Windows specific functions
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1993-1996 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2021 by Nathan Coulter. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Copyright © 2024 Nathan Coulter * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tcl.h -- * * This header file describes the externally-visible facilities of the * Tcl interpreter. * */ #ifndef _TCL #define _TCL /* * For C++ compilers, use extern "C" */ |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> #include <stddef.h> #if defined(__GNUC__) && (__GNUC__ > 2) # if defined(_WIN32) && defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__MINGW_PRINTF_FORMAT, a, b))) # else # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # endif | > > > > > > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> #include <stddef.h> /* Needed for PTRDIFF_MAX */ #include <stdint.h> #define TCL_COMMENT(x) #if defined(__GNUC__) && (__GNUC__ > 2) # if defined(_WIN32) && defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__MINGW_PRINTF_FORMAT, a, b))) # else # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # endif |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif | < < < < | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* * Make sure EXTERN isn't defined elsewhere. */ #ifdef EXTERN # undef EXTERN #endif /* EXTERN */ |
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | #endif /* !TCL_T_MODIFIER */ #define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) | < < < < < | | | < < | < < < < < | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
#endif /* !TCL_T_MODIFIER */
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
typedef ptrdiff_t Tcl_Size;
#define TCL_SIZE_MAX PTRDIFF_MAX
#define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#ifdef _WIN32
typedef struct __stat64 Tcl_StatBuf;
#elif defined(__CYGWIN__)
typedef struct {
unsigned st_dev;
unsigned short st_ino;
unsigned short st_mode;
short st_nlink;
short st_uid;
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
| < < < < < < < < < < | 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 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
Tcl_Size start; /* Character offset of first character in
* match. */
Tcl_Size end; /* Character offset of first character after
* the match. */
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
Tcl_Size nsubs; /* Number of subexpressions in the compiled
* expression. */
Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */
Tcl_Size extendStart; /* The offset at which a subsequent match
* might begin. */
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the struct's
* reference in tclDecls.h.
*/
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 | typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); | < < < < < < < | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef void (Tcl_FreeProc) (void *blockPtr); #define Tcl_ExitProc Tcl_FreeProc #define Tcl_FileFreeProc Tcl_FreeProc #define Tcl_EncodingFreeProc Tcl_FreeProc typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); typedef void (Tcl_TimerProc) (void *clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
617 618 619 620 621 622 623 | typedef void (Tcl_DeleteFileHandlerProc) (int fd); typedef void (Tcl_AlertNotifierProc) (void *clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); | < < < < < < < < < < < < < < < < < < < < < < < < > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
typedef void (Tcl_DeleteFileHandlerProc) (int fd);
typedef void (Tcl_AlertNotifierProc) (void *clientData);
typedef void (Tcl_ServiceModeHookProc) (int mode);
typedef void *(Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
/*
*----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
* internal representation for an object plus a set of functions that provide
* standard operations on objects of that type.
*/
/* forward declaration */
typedef struct Tcl_Obj Tcl_Obj;
typedef struct Tcl_ObjInterface Tcl_ObjInterface;
typedef struct Tcl_ObjType {
const char *name; /* Name of the type, e.g. "int". */
Tcl_FreeInternalRepProc *freeIntRepProc;
/* Called to free any storage for the type's
* internal rep. NULL if the internal rep does
* not need freeing. */
Tcl_DupInternalRepProc *dupIntRepProc;
/* Called to create a new object as a copy of
* an existing object. */
Tcl_UpdateStringProc *updateStringProc;
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
size_t version; /* Version field for future-proofing. */
} Tcl_ObjType;
/*
* The following structure stores an internal representation (internalrep) for
* a Tcl value. An internalrep is associated with an Tcl_ObjType when both
* are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
* the handling of the internalrep.
*/
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | /* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. */ | | | | 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 |
/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
*/
struct Tcl_Obj {
Tcl_Size refCount; /* When 0 the object will be freed. */
char *bytes; /* This points to the first byte of the
* object's string representation. The array
* must be followed by a null byte (i.e., at
* offset length) but may also contain
* embedded null characters. The array's
* storage is allocated by Tcl_Alloc. NULL means
* the string rep is invalid and must be
* regenerated from the internal rep. Clients
* should use Tcl_GetStringFromObj or
* Tcl_GetString to get a pointer to the byte
* array as a readonly value. */
Tcl_Size length; /* The number of bytes at *bytes, not
* including the terminating null. */
const Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
Tcl_ObjInternalRep internalRep;
/* The internal representation: */
};
/*
*----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
* five fields must match exactly the fields in a Namespace structure (see
* tclInt.h).
*/
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 | #define TCL_INDEX_TEMP_TABLE 64 /* * Flags that may be passed to Tcl_UniCharToUtf. * TCL_COMBINE Combine surrogates */ | < | < < < | 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 | #define TCL_INDEX_TEMP_TABLE 64 /* * Flags that may be passed to Tcl_UniCharToUtf. * TCL_COMBINE Combine surrogates */ #define TCL_COMBINE 0x1000000 /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! * * Meanings: |
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE | < | < < < | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE #define TCL_HASH_TYPE size_t #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); |
| ︙ | ︙ | |||
1182 1183 1184 1185 1186 1187 1188 |
* avoid mallocs and frees). */
Tcl_Size numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
Tcl_Size numEntries; /* Total number of entries present in
* table. */
Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
| < < < < < | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 |
* avoid mallocs and frees). */
Tcl_Size numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
Tcl_Size numEntries; /* Total number of entries present in
* table. */
Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
size_t mask; /* Mask value used in hashing function. */
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key,
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 |
/*
* The following structure keeps is used to hold a time value, either as an
* absolute time (the number of seconds from the epoch) or as an elapsed time.
* On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*/
typedef struct Tcl_Time {
| < < < < | | | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
/*
* The following structure keeps is used to hold a time value, either as an
* absolute time (the number of seconds from the epoch) or as an elapsed time.
* On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*/
typedef struct Tcl_Time {
long long sec; /* Seconds. */
#if defined(_WIN32) && defined(_WIN64)
int usec; /* Microseconds. */
#else
long usec; /* Microseconds. */
#endif
} Tcl_Time;
typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr);
typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr);
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 | #define TCL_CLOSE_WRITE (1<<2) /* * Value to use as the closeProc for a channel that supports the close2Proc * interface. */ | < | < < < | 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 | #define TCL_CLOSE_WRITE (1<<2) /* * Value to use as the closeProc for a channel that supports the close2Proc * interface. */ #define TCL_CLOSE2PROC NULL /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) |
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 |
* malloc-ed space if command exceeds space in
* staticTokens. */
Tcl_Size numTokens; /* Total number of tokens in command. */
Tcl_Size tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
| < < < < < | 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 |
* malloc-ed space if command exceeds space in
* staticTokens. */
Tcl_Size numTokens; /* Total number of tokens in command. */
Tcl_Size tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
* This information is used by
* Tcl_CommandComplete. */
/*
* The fields below are intended only for the private use of the parser.
* They should not be used by functions that invoke Tcl_ParseCommand.
*/
const char *string; /* The original command string passed to
* Tcl_ParseCommand. */
const char *end; /* Points to the character just after the last
* one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting, or
* NULL. */
const char *term; /* Points to character in string that
* terminated most recent token. Filled in by
* ParseTokens. If an error occurs, points to
* beginning of region where the error
* occurred (e.g. the open brace if the close
* brace is missing). */
Tcl_Token staticTokens[NUM_STATIC_TOKENS];
/* Initial space for tokens for command. This
* space should be large enough to accommodate
* most commands; dynamic space is allocated
* for very large commands that don't fit
* here. */
} Tcl_Parse;
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 | * block in a (potentially multi-block) input * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. | | | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 | * block in a (potentially multi-block) input * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - Obsolete. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills * all dstLen bytes with encoded UTF-8 content if * needed. If clear, a byte is reserved in the * dst space for NUL termination, and a * terminating NUL is appended. |
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 | * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tclEncoding.c (ENCODING_INPUT et al). Be cognizant of this * when adding bits. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 | < | < < < | | 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 | * NOTE: THESE BIT DEFINITIONS SHOULD NOT OVERLAP WITH INTERNAL USE BITS * DEFINED IN tclEncoding.c (ENCODING_INPUT et al). Be cognizant of this * when adding bits. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 /* Internal use bits, do not define bits in this space. See above comment */ #define TCL_ENCODING_INTERNAL_USE_MASK 0xFF00 /* * Reserve top byte for profile values (disjoint, not a mask). In case of * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if * necessary. */ #define TCL_ENCODING_PROFILE_STRICT 0x00000000 #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_REPLACE 0x02000000 /* * The following definitions are the error codes returned by the conversion * routines: * |
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 | * Unicode character in UTF-8. The valid values are 3 and 4. If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX | < < < < < | | | | | < < < < < | 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 | * Unicode character in UTF-8. The valid values are 3 and 4. If > 3, * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX # define TCL_UTF_MAX 4 #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. */ /* * int isn't 100% accurate as it should be a strict 4-byte value * (perhaps int32_t). ILP64/SILP64 systems may have troubles. The * size of this value must be reflected correctly in regcustom.h. */ typedef int Tcl_UniChar; /* *---------------------------------------------------------------------------- * TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to * provide the system with the embedded configuration data. */ |
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 | /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); | < < < < | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 | /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); #define Tcl_LimitHandlerDeleteProc Tcl_FreeProc #if 0 /* *---------------------------------------------------------------------------- * We would like to provide an anonymous structure "mp_int" here, which is * compatible with libtommath's "mp_int", but without duplicating anything * from <tommath.h> or including <tommath.h> here. But the libtommath project |
| ︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 | /* * Constants for special Tcl_Size-typed values, see TIP #494 */ #define TCL_IO_FAILURE ((Tcl_Size)-1) #define TCL_AUTO_LENGTH ((Tcl_Size)-1) #define TCL_INDEX_NONE ((Tcl_Size)-1) /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, int result); /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ | > < | < < < | 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 | /* * Constants for special Tcl_Size-typed values, see TIP #494 */ #define TCL_IO_FAILURE ((Tcl_Size)-1) #define TCL_AUTO_LENGTH ((Tcl_Size)-1) #define TCL_INDEX_NONE ((Tcl_Size)-1) #define TCL_LENGTH_NONE ((Tcl_Size)-1) /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, int result); /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ #define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the * main library in case an extension is statically linked into an application. */ |
| ︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 |
#if defined(_WIN32)
TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
#else
# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
#endif
#ifdef USE_TCL_STUBS
| < < < < < < < < < < < < | < < < < | | 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 |
#if defined(_WIN32)
TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
#else
# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
#endif
#ifdef USE_TCL_STUBS
#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#else
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0b3"), \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#endif
#else
#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
#else
# define Tcl_InitStubs(interp, version, exact) \
Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \
1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16))
|
| ︙ | ︙ | |||
2381 2382 2383 2384 2385 2386 2387 | EXTERN const char * Tcl_SetPreInitScript(const char *string); EXTERN const char * Tcl_SetPanicProc( Tcl_PanicProc *panicProc); EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); | < < < | | 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 |
EXTERN const char * Tcl_SetPreInitScript(const char *string);
EXTERN const char * Tcl_SetPanicProc(
Tcl_PanicProc *panicProc);
EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc);
#ifdef _WIN32
EXTERN const char * TclZipfs_AppHook(int *argc, wchar_t ***argv);
#else
EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
#endif
#if defined(_WIN32) && defined(UNICODE)
#ifndef USE_TCL_STUBS
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
#endif
# define Tcl_MainEx Tcl_MainExW
EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#if defined(USE_TCL_STUBS)
#define Tcl_SetPanicProc(panicProc) \
TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc))
#define Tcl_InitSubsystems() \
TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))())
#define Tcl_FindExecutable(argv0) \
TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0))
#define TclZipfs_AppHook(argcp, argvp) \
|
| ︙ | ︙ | |||
2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 | ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) #define Tcl_GetMemoryInfo(dsPtr) \ (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) #define Tcl_SetPreInitScript(string) \ ((const char *(*)(const char *))TclStubCall((void *)9))(string) #endif /* *---------------------------------------------------------------------------- * Include the public function declarations that are accessible via the stubs * table. */ #include "tclDecls.h" | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc)
#define Tcl_GetMemoryInfo(dsPtr) \
(void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr)
#define Tcl_SetPreInitScript(string) \
((const char *(*)(const char *))TclStubCall((void *)9))(string)
#endif
/*
*----------------------------------------------------------------
* Object interface data structures and macros
*----------------------------------------------------------------
*/
#define tclObjTypeInterfaceArgsListAll \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object for which an element array \
* is to be returned. */ \
Tcl_Size *objcPtr, /* Where to store the count of objects \
* referenced by objv. */ \
Tcl_Obj ***objvPtr /* Where to store the pointer to an \
* array of */
#define tclObjTypeInterfaceArgsListAppend \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to append objPtr to. */ \
Tcl_Obj *objPtr /* Object to append to listPtr's list. */
#define tclObjTypeInterfaceArgsListAppendList \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to append elements to. */ \
Tcl_Obj *elemListPtr /* List obj with elements to append. */
#define tclObjTypeInterfaceArgsListContains \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to append elements to. */ \
Tcl_Obj *givenPtr, /* Value to search for. */ \
int *resPtr /* Location to store the result in. */ \
#define tclObjTypeInterfaceArgsListIndex \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to index into. */ \
Tcl_Size index, /* Index of element to return. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsListIndexEnd \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to index into. */ \
Tcl_Size index, /* Index of element to return. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsListIsSorted \
Tcl_Interp * interp, /* Used to report errors */ \
Tcl_Obj *listPtr, /* The list in question */ \
size_t flags /* flags */
#define tclObjTypeInterfaceArgsListLength \
Tcl_Interp *interp, /* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object whose #elements to return. */ \
Tcl_Size *lenPtr /* The resulting length is stored here. */
#define tclObjTypeInterfaceArgsListRange \
Tcl_Interp *interp, /* Used to report errors */ \
Tcl_Obj *listPtr, /* List object to take a range from. */ \
Tcl_Size fromIdx, /* Index of first element to */ \
/* include. */ \
Tcl_Size toIdx, /* Index of last element to include. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsListRangeEnd \
Tcl_Interp * interp, /* Used to report errors */ \
Tcl_Obj *listPtr, /* List object to take a range from. */ \
Tcl_Size fromAnchor,/* 0 for start and 1 for end */ \
Tcl_Size fromIdx, /* Index of first element to include. */ \
Tcl_Size toAnchor, /* 0 for start and 1 for end */ \
Tcl_Size toIdx, /* Index of last element to include. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsListReplace \
Tcl_Interp *interp, /* Used for error reporting if not NULL. */ \
Tcl_Obj *listObj, /* List object whose elements to replace. */ \
Tcl_Size first, /* Index of first element to replace. */ \
Tcl_Size numToDelete, /* Number of elements to replace. */ \
Tcl_Size numToInsert, /* Number of objects to insert. */ \
/* An array of objc pointers to Tcl \
* objects to insert. */ \
Tcl_Obj *const insertObjs[]
#define tclObjTypeInterfaceArgsListReplaceList \
Tcl_Interp *interp, /* Used for error reporting if not NULL. */ \
Tcl_Obj *listPtr, /* List object whose elements to replace. */ \
Tcl_Size first, /* Index of first element to replace. */ \
Tcl_Size count, /* Number of elements to replace. */ \
Tcl_Obj *newItemsPtr /* a list of new items to insert */
#define tclObjTypeInterfaceArgsListReverse \
Tcl_Interp *interp, /* Used for error reporting if not NULL. */ \
Tcl_Obj *listPtr /* List object whose elements to replace. */ \
#define tclObjTypeInterfaceArgsListSet \
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting \
* if not NULL. */ \
Tcl_Obj *listObj, /* List object in which element should be \
* stored. */ \
Tcl_Size index, /* Index of element to store. */ \
Tcl_Obj *valueObj /* Tcl object to store in the designated list \
* element. */
#define tclObjTypeInterfaceArgsListSetDeep \
Tcl_Interp *interp, /* Tcl interpreter. */ \
Tcl_Obj *listObj, /* Pointer to the list being modified. */ \
Tcl_Size indexCount, /* Number of index args. */ \
Tcl_Obj *const indexArray[], /* Index args. */ \
Tcl_Obj *valueObj, /* Value arg to 'lset' or NULL to 'lpop'. */ \
Tcl_Obj **resPtrPtr /* An address at which to store the resulting list */
#define tclObjTypeInterfaceArgsStringIndex \
Tcl_Interp *interp, \
Tcl_Obj *objPtr, \
Tcl_Size index, \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsStringIndexEnd \
Tcl_Interp *interp, \
Tcl_Obj *objPtr, \
Tcl_Size index, \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsStringLength \
Tcl_Obj *listPtr, \
Tcl_Size *lengthPtr /* An address at which to store the length. */
#define tclObjTypeInterfaceArgsStringIsEmpty \
Tcl_Interp *interp, \
Tcl_Obj *listPtr, \
int *res
#define tclObjTypeInterfaceArgsStringRange \
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ \
Tcl_Size first, /* First index of the range. */ \
Tcl_Size last, /* Last index of the range. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
#define tclObjTypeInterfaceArgsStringRangeEnd \
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ \
Tcl_Size first, /* First index of the range. */ \
Tcl_Size last, /* Last index of the range. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
typedef int (Tcl_ObjInterfaceListAllProc)(tclObjTypeInterfaceArgsListAll);
typedef int (Tcl_ObjInterfaceListAppendProc)(tclObjTypeInterfaceArgsListAppend);
typedef int (Tcl_ObjInterfaceListAppendlistProc)(tclObjTypeInterfaceArgsListAppendList);
typedef int (Tcl_ObjInterfaceListContainsProc)(tclObjTypeInterfaceArgsListContains);
typedef int (Tcl_ObjInterfaceListIndexProc)(tclObjTypeInterfaceArgsListIndex);
typedef int (Tcl_ObjInterfaceListIndexEndProc)(tclObjTypeInterfaceArgsListIndexEnd);
typedef int (Tcl_ObjInterfaceListIsSortedProc)(tclObjTypeInterfaceArgsListIsSorted);
typedef int (Tcl_ObjInterfaceListLengthProc)(tclObjTypeInterfaceArgsListLength);
typedef int (Tcl_ObjInterfaceListRangeProc)(tclObjTypeInterfaceArgsListRange);
typedef int (Tcl_ObjInterfaceListRangeEndProc)(tclObjTypeInterfaceArgsListRangeEnd);
typedef int (Tcl_ObjInterfaceListReplaceProc)(tclObjTypeInterfaceArgsListReplace);
typedef int (Tcl_ObjInterfaceListReplaceListProc)(tclObjTypeInterfaceArgsListReplaceList);
typedef int (Tcl_ObjInterfaceListReverseProc)(tclObjTypeInterfaceArgsListReverse);
typedef int (Tcl_ObjInterfaceListSetProc)(tclObjTypeInterfaceArgsListSet);
typedef int (Tcl_ObjInterfaceListSetDeepProc)(tclObjTypeInterfaceArgsListSetDeep);
typedef int (Tcl_ObjInterfaceStringIndexProc)(tclObjTypeInterfaceArgsStringIndex);
typedef int (Tcl_ObjInterfaceStringIndexEndProc)(tclObjTypeInterfaceArgsStringIndexEnd);
typedef int (Tcl_ObjInterfaceStringIsEmptyProc)(tclObjTypeInterfaceArgsStringIsEmpty);
typedef int (Tcl_ObjInterfaceStringLengthProc)(tclObjTypeInterfaceArgsStringLength);
typedef int (Tcl_ObjInterfaceStringRangeProc)(tclObjTypeInterfaceArgsStringRange);
typedef int (Tcl_ObjInterfaceStringRangeEndProc)(tclObjTypeInterfaceArgsStringRangeEnd);
/*
*----------------------------------------------------------------------------
* Include the public function declarations that are accessible via the stubs
* table.
*/
#include "tclDecls.h"
|
| ︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 | */ #ifndef BUILD_tcl # define ckalloc Tcl_Alloc # define attemptckalloc Tcl_AttemptAlloc # ifdef _MSC_VER /* Silence invalid C4090 warnings */ | | | | | | 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 | */ #ifndef BUILD_tcl # define ckalloc Tcl_Alloc # define attemptckalloc Tcl_AttemptAlloc # ifdef _MSC_VER /* Silence invalid C4090 warnings */ # define ckfree(a) Tcl_Free((void *)(a)) # define ckrealloc(a, b) Tcl_Realloc((void *)(a), (b)) # define attemptckrealloc(a, b) Tcl_AttemptRealloc((void *)(a), (b)) # else # define ckfree Tcl_Free # define ckrealloc Tcl_Realloc # define attemptckrealloc Tcl_AttemptRealloc # endif #endif #ifndef TCL_MEM_DEBUG /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, * et al. routines in order to guarantee that every module is using the same * memory allocator both inside and outside of the Tcl library. */ # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory # define Tcl_DumpActiveMemory(x) # undef Tcl_ValidateAllMemory # define Tcl_ValidateAllMemory(x, y) #endif /* !TCL_MEM_DEBUG */ #ifdef TCL_MEM_DEBUG # undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) |
| ︙ | ︙ | |||
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 | #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) #undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) #endif /* RC_INVOKED */ /* * end block for C++ */ #ifdef __cplusplus } #endif #endif /* _TCL */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ | > > > | 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 | #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) #undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) #endif /* RC_INVOKED */ /* * end block for C++ */ #ifdef __cplusplus } #endif #endif /* _TCL */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
1 | /* | < < < < < < < > > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1983 Regents of the University of California. * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclAlloc.c -- * * This is a very fast storage allocator. It allocates blocks of a small * number of different sizes, and keeps free lists of each size. Blocks * that don't exactly fit are passed up to the next larger size. Blocks * over a certain size are directly allocated from the system. * */ /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #include "tclInt.h" |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); overPtr->rangeCheckMagic = RMAGIC; BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
overPtr->rangeCheckMagic = RMAGIC;
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (void *)(overPtr + 1);
}
/*
* Convert amount of memory requested into closest block size stored in
* hash buckets which satisfies request. Account for space used per block
* for accounting.
*/
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 | */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 |
*/
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (void *)(overPtr + 1);
}
maxSize = (size_t)1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
} else if (i>0 && numBytes+OVERHEAD < maxSize/2) {
expensive = 1;
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 | * *---------------------------------------------------------------------- */ #undef TclpAlloc void * TclpAlloc( | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 |
*
*----------------------------------------------------------------------
*/
#undef TclpAlloc
void *
TclpAlloc(
size_t numBytes) /* Number of bytes to allocate. */
{
return malloc(numBytes);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclArithSeries.c -- * * This file contains the ArithSeries concrete abstract list * implementation. It implements the inner workings of the lseq command. * * Copyright © 2022 Brian S. Griffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <assert.h> #include <math.h> /* * The structure below defines the arithmetic series Tcl object type by * means of procedures that can be invoked by generic object code. | > > > > > > > > > > > > | 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 | /* * tclArithSeries.c -- * * This file contains the ArithSeries concrete abstract list * implementation. It implements the inner workings of the lseq command. * * Copyright © 2022 Brian S. Griffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Copyright © 2024 Nathan Coulter * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" #include "tclInt.h" #include <assert.h> #include <math.h> /* * The structure below defines the arithmetic series Tcl object type by * means of procedures that can be invoked by generic object code. |
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
double end;
double step;
unsigned precision; /* Number of decimal places to render. */
} ArithSeriesDbl;
/* Forward declarations. */
| | | < | | < < | < | | | < < < < < > > > > | | | | | > > > | > | > > > > | > | | | | > | < < | | 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 |
double end;
double step;
unsigned precision; /* Number of decimal places to render. */
} ArithSeriesDbl;
/* Forward declarations. */
static Tcl_ObjInterfaceListContainsProc ArithSeriesInOperation;
static Tcl_ObjInterfaceListIndexProc ArithSeriesObjIndex;
static Tcl_ObjInterfaceListLengthProc ArithSeriesObjLength;
static Tcl_ObjInterfaceListRangeProc ArithSeriesObjRange;
static Tcl_ObjInterfaceListReverseProc ArithSeriesObjReverse;
static Tcl_ObjInterfaceListAllProc ArithSeriesGetElements;
static int ArithSeriesObjStep(Tcl_Obj *arithSeriesObj,
Tcl_Obj **stepObj);
static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr);
static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
static int SetArithSeriesFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* ------------------------ ArithSeries object type -------------------------- */
static int ArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj);
static ObjectType arithSeriesType = {
"arithseries",
FreeArithSeriesInternalRep, /* freeIntRepProc */
DupArithSeriesInternalRep, /* dupIntRepProc */
UpdateStringOfArithSeries, /* updateStringProc */
SetArithSeriesFromAny, /* setFromAnyProc */
2,
NULL
};
void TclArithSeriesInit(void) {
Tcl_ObjInterface *oiPtr;
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListContains(oiPtr ,ArithSeriesInOperation);
Tcl_ObjInterfaceSetFnListAll(oiPtr ,ArithSeriesGetElements);
Tcl_ObjInterfaceSetFnListIndex(oiPtr ,ArithSeriesObjIndex);
Tcl_ObjInterfaceSetFnListLength(oiPtr ,ArithSeriesObjLength);
Tcl_ObjInterfaceSetFnListRange(oiPtr ,ArithSeriesObjRange);
Tcl_ObjInterfaceSetFnListReverse(oiPtr ,ArithSeriesObjReverse);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&arithSeriesType ,oiPtr);
return;
}
/*
* Helper functions
*
* - power10 -- Fast version of pow(10, (int) n) for common cases.
* - ArithRound -- Round doubles to the number of significant fractional
* digits
* - ArithSeriesIndexDbl -- base list indexing operation for doubles
* - ArithSeriesIndexInt -- " " " " " integers
* - ArithSeriesGetInternalRep -- Return the internal rep from a Tcl_Obj
* - Precision -- determine the number of factional digits for the given
* double value
* - maxPrecision -- Using the values provided, determine the longest precision
* in the arithSeries
*/
static inline double
power10(
unsigned n)
{
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
unsigned i = Precision(start);
dp = i>dp ? i : dp;
i = Precision(end);
dp = i>dp ? i : dp;
return dp;
}
| | | < | | < > | < | | 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 |
unsigned i = Precision(start);
dp = i>dp ? i : dp;
i = Precision(end);
dp = i>dp ? i : dp;
return dp;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesLen --
*
* Compute the length of the equivalent list where every element is generated
* starting from *start*, and adding *step* to generate every successive
* element that's < *end* for positive steps, or > *end* for negative steps.
*
* Results:
*
* The length of the list generated by the given range, that may be zero. The
* function returns -1 if the list is of length infinite.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
istart = start * power10(precision);
iend = end * power10(precision);
istep = step * power10(precision);
ilen = (iend - istart + istep) / istep;
return floor(ilen);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
istart = start * power10(precision);
iend = end * power10(precision);
istep = step * power10(precision);
ilen = (iend - istart + istep) / istep;
return floor(ilen);
}
/*
*----------------------------------------------------------------------
*
* NewArithSeriesInt --
*
* Creates a new ArithSeries object. The returned object has
* refcount = 0.
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
arithSeriesRepPtr->base.elements = NULL;
arithSeriesRepPtr->base.isDouble = 0;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
| | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
arithSeriesRepPtr->base.elements = NULL;
arithSeriesRepPtr->base.isDouble = 0;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = (Tcl_ObjType *)&arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
}
|
| ︙ | ︙ | |||
472 473 474 475 476 477 478 |
arithSeriesRepPtr->base.isDouble = 1;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->precision = maxPrecision(start, end, step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
| | | | 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 |
arithSeriesRepPtr->base.isDouble = 1;
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->precision = maxPrecision(start, end, step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = (Tcl_ObjType *)&arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
}
/*
*----------------------------------------------------------------------
*
* assignNumber --
*
* Create the appropriate Tcl_Obj value for the given numeric values.
* Used locally only for decoding [lseq] numeric arguments.
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer. No assignment on error.
*
* Side Effects:
* None.
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 | /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | /* *---------------------------------------------------------------------- * * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. Some arguments may be NULL and will * be computed based on the other given arguments. * refcount = 0. * * Results: * A Tcl_Obj pointer to the created ArithSeries object. * NULL if the range is invalid. * * Side Effects: * None. |
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
if (!endObj) {
if (useDoubles) {
// Compute precision based on given command argument values
unsigned precision = maxPrecision(dstart, len, dstep);
dend = dstart + (dstep * (len-1));
| | | | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
if (!endObj) {
if (useDoubles) {
// Compute precision based on given command argument values
unsigned precision = maxPrecision(dstart, len, dstep);
dend = dstart + (dstep * (len-1));
// Make computed end value match argument(s) precision
dend = ArithRound(dend, precision);
end = dend;
} else {
end = start + (step * (len - 1));
dend = end;
}
}
if (len > TCL_SIZE_MAX) {
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
: NewArithSeriesInt(start, end, step, len);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
| | | | < < < > | > | | | | 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 |
: NewArithSeriesInt(start, end, step, len);
return objPtr;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesObjIndex --
*
* Stores in **resultPtr the element with the specified index in the list
* represented by the specified Arithmetic Sequence object.
*
* Results:
*
* On success, returns TCL_OK and stores the position of the element in
* *element. Returns TCL_ERROR if the given index is out of range.
*
* Side Effects:
* On success, stores the stores the position of the element in *elemObj,
* and on failure, stores the empty string ("").
*
*----------------------------------------------------------------------
*/
int
ArithSeriesObjIndex(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *arithSeriesObj, /* List obj */
Tcl_Size index, /* index to element of interest */
Tcl_Obj **elemObj) /* Return value */
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 | * The length of the series as Tcl_WideInt. * * Side Effects: * None. * *---------------------------------------------------------------------- */ | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | | > | > > | > > | | | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
* The length of the series as Tcl_WideInt.
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
int ArithSeriesObjLength(TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *arithSeriesObj
,Tcl_Size *result)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
*result = arithSeriesRepPtr->len;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DupArithSeriesInternalRep --
*
* Initialize the internal representation of a arithseries Tcl_Obj to a
* copy of the internal representation of an existing arithseries object.
* The copy does not share the cache of the elements.
*
* Results:
* None.
*
* Side effects:
* We set "copyPtr"s internal rep to a pointer to a
* newly allocated ArithSeries structure.
*
*----------------------------------------------------------------------
*/
static void
DupArithSeriesInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ArithSeries *srcRepPtr = (ArithSeries *)
srcPtr->internalRep.twoPtrValue.ptr1;
if (srcRepPtr->isDouble) {
ArithSeriesDbl *srcDblPtr = (ArithSeriesDbl *) srcRepPtr;
ArithSeriesDbl *copyDblPtr = (ArithSeriesDbl *)
Tcl_Alloc(sizeof(ArithSeriesDbl));
*copyDblPtr = *srcDblPtr;
copyDblPtr->base.elements = NULL;
copyPtr->internalRep.twoPtrValue.ptr1 = copyDblPtr;
} else {
ArithSeriesInt *srcIntPtr = (ArithSeriesInt *) srcRepPtr;
ArithSeriesInt *copyIntPtr = (ArithSeriesInt *)
Tcl_Alloc(sizeof(ArithSeriesInt));
*copyIntPtr = *srcIntPtr;
copyIntPtr->base.elements = NULL;
copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr;
}
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = (Tcl_ObjType *)&arithSeriesType;
}
/*
*----------------------------------------------------------------------
*
* FreeArithSeriesInternalRep --
*
* Free any allocated memory in the ArithSeries Rep
*
* Results:
* None.
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static inline void
FreeElements(
ArithSeries *arithSeriesRepPtr)
{
if (arithSeriesRepPtr->elements) {
Tcl_WideInt i, len = arithSeriesRepPtr->len;
for (i=0; i<len; i++) {
Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
}
Tcl_Free((char *) arithSeriesRepPtr->elements);
arithSeriesRepPtr->elements = NULL;
}
}
static void
FreeArithSeriesInternalRep(
Tcl_Obj *arithSeriesObjPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
if (arithSeriesRepPtr) {
FreeElements(arithSeriesRepPtr);
Tcl_Free((char *) arithSeriesRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesObjStep --
*
* Return a Tcl_Obj with the step value from the give ArithSeries Obj.
* refcount = 0.
*
* Results:
* A Tcl_Obj pointer to the created ArithSeries object.
* A NULL pointer of the range is invalid.
*
* Side Effects:
* None.
*----------------------------------------------------------------------
*/
static int
ArithSeriesObjStep(
Tcl_Obj *arithSeriesObj,
Tcl_Obj **stepObj)
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (arithSeriesRepPtr->isDouble) {
*stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl *) arithSeriesRepPtr)->step);
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | * Tcl Panic if called. * *---------------------------------------------------------------------- */ static int SetArithSeriesFromAny( | | | | | | | | | | | | | | | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
* Tcl Panic if called.
*
*----------------------------------------------------------------------
*/
static int
SetArithSeriesFromAny(
TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */
{
Tcl_Panic("SetArithSeriesFromAny: should never be called");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesObjRange --
*
* Makes a slice of an ArithSeries value.
* *arithSeriesObj must be known to be a valid list.
*
* Results:
* Returns a pointer to the sliced series.
* This may be a new object or the same object if not shared.
*
* Side effects:
* ?The possible conversion of the object referenced by listPtr?
* ?to a list object.?
*
*----------------------------------------------------------------------
*/
int
ArithSeriesObjRange(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj,/* List object to take a range from. */
Tcl_Size fromIdx, /* Index of first element to include. */
Tcl_Size toIdx, /* Index of last element to include. */
Tcl_Obj **resPtrPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
(void)interp; /* silence compiler */
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
if (toIdx >= arithSeriesRepPtr->len) {
toIdx = arithSeriesRepPtr->len-1;
}
if (fromIdx > toIdx || fromIdx >= arithSeriesRepPtr->len) {
TclNewObj(*resPtrPtr);
return TCL_OK;
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx < 0) {
toIdx = 0;
}
if (toIdx > arithSeriesRepPtr->len - 1) {
toIdx = arithSeriesRepPtr->len - 1;
}
ArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
Tcl_IncrRefCount(startObj);
ArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
Tcl_IncrRefCount(endObj);
ArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) {
Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(interp,
arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);
*resPtrPtr = newSlicePtr;
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
return newSlicePtr ? TCL_OK : TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
intRepPtr->base.len = ArithSeriesLenInt(start, end, step);
}
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
| | | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
intRepPtr->base.len = ArithSeriesLenInt(start, end, step);
}
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
*resPtrPtr = arithSeriesObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesGetElements --
*
* This function returns an (objc,objv) array of the elements in a list
* object.
*
* Results:
* The return value is normally TCL_OK; in this case *objcPtr is set to
* the count of list elements and *objvPtr is set to a pointer to an
|
| ︙ | ︙ | |||
927 928 929 930 931 932 933 | * Side effects: * None. * *---------------------------------------------------------------------- */ int | | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 |
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
ArithSeriesGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *objPtr, /* ArithSeries object for which an element
* array is to be returned. */
Tcl_Size *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
if (TclHasInternalRep(objPtr,(Tcl_ObjType *)&arithSeriesType)) {
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
Tcl_Obj **objv;
Tcl_Size objc = arithSeriesRepPtr->len;
if (objc > 0) {
if (arithSeriesRepPtr->elements) {
/* If this exists, it has already been populated */
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
}
return TCL_ERROR;
}
arithSeriesRepPtr->elements = objv;
Tcl_Size i;
for (i = 0; i < objc; i++) {
| | | 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
}
return TCL_ERROR;
}
arithSeriesRepPtr->elements = objv;
Tcl_Size i;
for (i = 0; i < objc; i++) {
int status = ArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
if (status) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objv[i]);
}
}
|
| ︙ | ︙ | |||
988 989 990 991 992 993 994 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | < > < | | | | | < < < < < < < < < < < < | | | | | | | | | | | | | < | < | | < | | 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 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesObjReverse --
*
* Reverse the order of the ArithSeries value. The arithSeriesObj is
* assumed to be a valid ArithSeries. The new Obj has the Start and End
* values appropriately swapped and the Step value sign is changed.
*
* Results:
* The result will be an ArithSeries in the reverse order.
*
* Side effects:
* The original obj will be modified and returned if it is not Shared.
*
*----------------------------------------------------------------------
*/
int
ArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj /* List object to reverse. */
)
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
Tcl_WideInt start, end, step, len;
double dstart, dend, dstep;
int isDouble;
(void)interp;
if (Tcl_IsShared(arithSeriesObj)) {
Tcl_Panic("%s called with shared object", "ArithSeriesObjReverse");
}
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
isDouble = arithSeriesRepPtr->isDouble;
len = arithSeriesRepPtr->len;
ArithSeriesObjIndex(NULL, arithSeriesObj, len - 1, &startObj);
Tcl_IncrRefCount(startObj);
ArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj);
Tcl_IncrRefCount(endObj);
ArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (isDouble) {
Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
Tcl_GetDoubleFromObj(NULL, endObj, &dend);
Tcl_GetDoubleFromObj(NULL, stepObj, &dstep);
dstep = -dstep;
TclSetDoubleObj(stepObj, dstep);
} else {
Tcl_GetWideIntFromObj(NULL, startObj, &start);
Tcl_GetWideIntFromObj(NULL, endObj, &end);
Tcl_GetWideIntFromObj(NULL, stepObj, &step);
step = -step;
TclSetIntObj(stepObj, step);
}
TclInvalidateStringRep(arithSeriesObj);
if (isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr;
dblRepPtr->start = dstart;
dblRepPtr->end = dend;
dblRepPtr->step = dstep;
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr;
intRepPtr->start = start;
intRepPtr->end = end;
intRepPtr->step = step;
}
FreeElements(arithSeriesRepPtr);
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfArithSeries --
*
* Update the string representation for an arithseries object.
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | * much faster. Because the programmer shouldn't expect the * string conversion of a big arithmetic sequence to be fast * this version takes more care of space than time. * *---------------------------------------------------------------------- */ static void | | < | | | | | | | | | > > | | | < > | | | | | | | | | | | | | 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 |
* much faster. Because the programmer shouldn't expect the
* string conversion of a big arithmetic sequence to be fast
* this version takes more care of space than time.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesPtr->internalRep.twoPtrValue.ptr1;
char *p;
Tcl_Obj *elemObj;
Tcl_Size i, bytlen = 0;
/*
* Pass 1: estimate space.
*/
if (!arithSeriesRepPtr->isDouble) {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexInt(arithSeriesRepPtr, i);
size_t slen = d>0 ? log10(d)+1 : d<0 ? log10(-d)+2 : 1;
bytlen += slen;
}
} else {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
char tmp[TCL_DOUBLE_SPACE + 2];
tmp[0] = 0;
Tcl_PrintDouble(NULL, d, tmp);
if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) {
break; // overflow
}
bytlen += strlen(tmp);
}
}
bytlen += arithSeriesRepPtr->len; // Space for each separator
/*
* Pass 2: generate the string repr.
*/
p = Tcl_InitStringRep(arithSeriesPtr, NULL, bytlen);
for (i = 0; i < arithSeriesRepPtr->len; i++) {
if (ArithSeriesObjIndex(NULL, arithSeriesPtr, i, &elemObj) == TCL_OK) {
Tcl_Size slen;
char *str = Tcl_GetStringFromObj(elemObj, &slen);
strcpy(p, str);
p[slen] = ' ';
p += slen + 1;
Tcl_DecrRefCount(elemObj);
} // else TODO: report error here?
}
if (bytlen > 0) {
arithSeriesPtr->bytes[bytlen - 1] = '\0';
}
arithSeriesPtr->length = bytlen - 1;
return;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesInOperator --
*
* Evaluate the "in" operation for expr
*
* This can be done more efficiently in the Arith Series relative to
* doing a linear search as implemented in expr.
*
* Results:
* Boolean true or false (1/0)
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
static int
ArithSeriesInOperation(
Tcl_Interp *interp,
Tcl_Obj *arithSeriesObjPtr,
Tcl_Obj *valueObj,
int *boolResult)
{
ArithSeries *repPtr = (ArithSeries *)
arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
int status;
Tcl_Size index, incr, elen, vlen;
if (repPtr->isDouble) {
ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) repPtr;
double y;
int test = 0;
incr = 0; // Check index+incr where incr is 0 and 1
status = Tcl_GetDoubleFromObj(interp, valueObj, &y);
if (status != TCL_OK) {
test = 0;
} else {
char *vstr = Tcl_GetStringFromObj(valueObj, &vlen);
index = (y - dblRepPtr->start) / dblRepPtr->step;
while (incr<2) {
Tcl_Obj *elemObj;
elen = 0;
ArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj);
const char *estr = elemObj ? Tcl_GetStringFromObj(elemObj, &elen) : "";
/* "in" operation defined as a string compare */
test = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0;
Tcl_BounceRefCount(elemObj);
/* Stop if we have a match */
if (test) {
break;
}
incr++;
}
}
if (boolResult) {
*boolResult = test;
}
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *) repPtr;
Tcl_WideInt y;
status = Tcl_GetWideIntFromObj(NULL, valueObj, &y);
if (status != TCL_OK) {
if (boolResult) {
*boolResult = 0;
}
} else {
Tcl_Obj *elemObj;
elen = 0;
index = (y - intRepPtr->start) / intRepPtr->step;
ArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj);
char const *vstr = Tcl_GetStringFromObj(valueObj, &vlen);
char const *estr = elemObj ? Tcl_GetStringFromObj(elemObj, &elen) : "";
if (boolResult) {
*boolResult = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0;
}
Tcl_BounceRefCount(elemObj);
}
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | /* * tclAssembly.c -- * * Assembler for Tcl bytecodes. * * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * | > > > > > > > > > > > > > > > > > < < < < < | | 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 | /* * Copyright © 2010 Ozgur Dogan Ugurlu. * Copyright © 2010 Kevin B. Kenny. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclAssembly.c -- * * Assembler for Tcl bytecodes. * * This file contains the procedures that convert Tcl Assembly Language (TAL) * to a sequence of bytecode instructions for the Tcl execution engine. * */ /*- *- THINGS TO DO: *- More instructions: *- done - alternate exit point (affects stack and exception range checking) *- break and continue - if exception ranges can be sorted out. *- foreach_start4, foreach_step4 |
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
typedef struct AssemblyEnv {
CompileEnv* envPtr; /* Compilation environment being used for code
* generation */
Tcl_Parse* parsePtr; /* Parse of the current line of source */
Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose
* values are 'label' objects storing the code
* offsets of the labels. */
| | | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
typedef struct AssemblyEnv {
CompileEnv* envPtr; /* Compilation environment being used for code
* generation */
Tcl_Parse* parsePtr; /* Parse of the current line of source */
Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose
* values are 'label' objects storing the code
* offsets of the labels. */
Tcl_Size cmdLine; /* Current line number within the assembly
* code */
Tcl_Size* clNext; /* Invisible continuation line for
* [info frame] */
BasicBlock* head_bb; /* First basic block in the code */
BasicBlock* curr_bb; /* Current basic block */
int maxDepth; /* Maximum stack depth encountered */
int curCatchDepth; /* Current depth of catches */
int maxCatchDepth; /* Maximum depth of catches encountered */
int flags; /* Compilation flags (TCL_EVAL_DIRECT) */
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 |
*/
static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep;
static Tcl_DupInternalRepProc DupAssembleCodeInternalRep;
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
| | | | | < > | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
*/
static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep;
static Tcl_DupInternalRepProc DupAssembleCodeInternalRep;
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep,
DupAssembleCodeInternalRep,
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
static const TalInstDesc TalInstructionTable[] = {
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
CompileAssembleObj(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Source code to assemble */
{
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
| | < | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 |
CompileAssembleObj(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Source code to assemble */
{
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
ByteCode *codePtr = NULL; /* Bytecode resulting from the assembly */
Namespace* namespacePtr; /* Namespace in which variable and command
* names in the bytecode resolve */
int status; /* Status return from Tcl_AssembleCode */
const char* source; /* String representation of the source code */
Tcl_Size sourceLen; /* Length of the source code in bytes */
/*
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
* Set up the compilation environment, and assemble the code.
*/
| | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL);
}
/*
* Set up the compilation environment, and assemble the code.
*/
source = Tcl_GetStringFromObj(objPtr, &sourceLen);
TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
if (status != TCL_OK) {
/*
* Assembly failed. Clean up and report the error.
*/
TclFreeCompileEnv(&compEnv);
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 |
TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
Tcl_Size operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
| | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 |
TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
Tcl_Size operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
Tcl_Size localVar; /* LVT index of a local variable */
int flags; /* Flags for a basic block */
JumptableInfo* jtPtr; /* Pointer to a jumptable */
int infoIndex; /* Index of the jumptable in auxdata */
int status = TCL_ERROR; /* Return value from this function */
/*
* Make sure that the instruction name is known at compile time.
|
| ︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 |
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
| | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 |
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
case ASSEM_1BYTE:
if (parsePtr->numWords != 1) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
|
| ︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 |
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblIdx);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
| | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblIdx);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
*/
BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
|
| ︙ | ︙ | |||
1959 1960 1961 1962 1963 1964 1965 |
*/
static int
CreateMirrorJumpTable(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Obj* jumps) /* List of alternating keywords and labels */
{
| | | 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 |
*/
static int
CreateMirrorJumpTable(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
Tcl_Obj* jumps) /* List of alternating keywords and labels */
{
Tcl_Size objc; /* Number of elements in the 'jumps' list */
Tcl_Obj** objv; /* Pointers to the elements in the list */
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
|
| ︙ | ︙ | |||
2309 2310 2311 2312 2313 2314 2315 |
const char* varNameStr;
Tcl_Size varNameLen;
Tcl_Size localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
| | | 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 |
const char* varNameStr;
Tcl_Size varNameLen;
Tcl_Size localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return TCL_INDEX_NONE;
}
localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
Tcl_DecrRefCount(varNameObj);
if (localVar < 0) {
|
| ︙ | ︙ | |||
3816 3817 3818 3819 3820 3821 3822 |
}
/*
* All blocks referenced in a jump table are successors.
*/
if (bbPtr->flags & BB_JUMPTABLE) {
| | | 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 |
}
/*
* All blocks referenced in a jump table are successors.
*/
if (bbPtr->flags & BB_JUMPTABLE) {
for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable, &jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > > | | | 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 |
/*
* Copyright © 1993 The Regents of the University of California.
* Copyright © 1994 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclAsync.c --
*
* This file provides low-level support needed to invoke signal handlers
* in a safe way. The code here doesn't actually handle signals, though.
* This code is based on proposals made by Mark Diekhans and Don Libes.
*
*/
#include "tclInt.h"
/* Forward declaration */
struct ThreadSpecificData;
/*
* One of the following structures exists for each asynchronous handler:
*/
typedef struct AsyncHandler {
int ready; /* Non-zero means this handler should be
* invoked in the next call to
* Tcl_AsyncInvoke. */
struct AsyncHandler *nextPtr, *prevPtr;
/* Next, previous in list of all handlers
* for the process. */
Tcl_AsyncProc *proc; /* Procedure to call when handler is
* invoked. */
void *clientData; /* Value to pass to handler when it is
* invoked. */
struct ThreadSpecificData *originTsd;
/* Used in Tcl_AsyncMark to modify thread-
* specific data from outside the thread it is
* associated to. */
Tcl_ThreadId originThrdId; /* Origin thread where this token was created
* and where it will be yielded. */
void *notifierData; /* Platform notifier data or NULL. */
} AsyncHandler;
typedef struct ThreadSpecificData {
int asyncReady; /* This is set to 1 whenever a handler becomes
* ready and it is cleared to zero whenever
* Tcl_AsyncInvoke is called. It can be
* checked elsewhere in the application by
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
*----------------------------------------------------------------------
*/
Tcl_AsyncHandler
Tcl_AsyncCreate(
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
| | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
*----------------------------------------------------------------------
*/
Tcl_AsyncHandler
Tcl_AsyncCreate(
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
void *clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ void Tcl_AsyncMark( | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
* The handler gets marked for invocation later.
*
*----------------------------------------------------------------------
*/
void
Tcl_AsyncMark(
Tcl_AsyncHandler async) /* Token for handler. */
{
AsyncHandler *token = (AsyncHandler *) async;
Tcl_MutexLock(&asyncMutex);
token->ready = 1;
if (!token->originTsd->asyncActive) {
token->originTsd->asyncReady = 1;
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 | * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ int Tcl_AsyncMarkFromSignal( | | | | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
* The handler gets marked for invocation later.
*
*----------------------------------------------------------------------
*/
int
Tcl_AsyncMarkFromSignal(
Tcl_AsyncHandler async, /* Token for handler. */
int sigNumber) /* Signal number. */
{
#if TCL_THREADS
AsyncHandler *token = (AsyncHandler *) async;
return TclAsyncNotifier(sigNumber, token->originThrdId,
token->notifierData, &token->ready, -1);
#else
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 | * deleted by some other thread. * *---------------------------------------------------------------------- */ void Tcl_AsyncDelete( | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
* deleted by some other thread.
*
*----------------------------------------------------------------------
*/
void
Tcl_AsyncDelete(
Tcl_AsyncHandler async) /* Token for handler to delete. */
{
AsyncHandler *asyncPtr = (AsyncHandler *) async;
/*
* Assure early handling of the constraint
*/
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright © 1987-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001, 2002 Kevin B. Kenny. All rights reserved. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * Copyright © 2008 Miguel Sofer <msofer@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation and * deletion, and command/script execution. * */ #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> |
| ︙ | ︙ | |||
147 148 149 150 151 152 153 | TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts * are used to save the evaluation state between NR calls to each coro. */ | | > | | | | > | > | | | | > | 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 |
TCL_DECLARE_MUTEX(commandTypeLock);
/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
* are used to save the evaluation state between NR calls to each coro.
*/
#define SAVE_CONTEXT(context) \
do { \
(context).framePtr = iPtr->framePtr; \
(context).varFramePtr = iPtr->varFramePtr; \
(context).cmdFramePtr = iPtr->cmdFramePtr; \
(context).lineLABCPtr = iPtr->lineLABCPtr; \
} while (0)
#define RESTORE_CONTEXT(context) \
do { \
iPtr->framePtr = (context).framePtr; \
iPtr->varFramePtr = (context).varFramePtr; \
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr; \
} while (0)
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 8) {
Tcl_Panic("<time.h> is not compatible with VS2005+");
}
| | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 8) {
Tcl_Panic("<time.h> is not compatible with VS2005+");
}
if ((offsetof(Tcl_StatBuf, st_atime) != 32)
|| (offsetof(Tcl_StatBuf, st_ctime) != 48)) {
Tcl_Panic("<sys/stat.h> is not compatible with VS2005+");
}
#endif
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
|
| ︙ | ︙ | |||
920 921 922 923 924 925 926 |
iPtr->returnOpts = NULL;
iPtr->errorInfo = NULL;
TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
Tcl_IncrRefCount(iPtr->eiVar);
iPtr->errorStack = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(iPtr->errorStack);
iPtr->resetErrorStack = 1;
| | | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
iPtr->returnOpts = NULL;
iPtr->errorInfo = NULL;
TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
Tcl_IncrRefCount(iPtr->eiVar);
iPtr->errorStack = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(iPtr->errorStack);
iPtr->resetErrorStack = 1;
TclNewLiteralStringObj(iPtr->upLiteral, "UP");
Tcl_IncrRefCount(iPtr->upLiteral);
TclNewLiteralStringObj(iPtr->callLiteral, "CALL");
Tcl_IncrRefCount(iPtr->callLiteral);
TclNewLiteralStringObj(iPtr->innerLiteral, "INNER");
Tcl_IncrRefCount(iPtr->innerLiteral);
iPtr->innerContext = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(iPtr->innerContext);
iPtr->errorCode = NULL;
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
Tcl_IncrRefCount(iPtr->ecVar);
iPtr->returnLevel = 1;
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
/*
* Register "clock" subcommands. These *do* go through
* Tcl_CreateObjCommand, since they aren't in the global namespace and
* involve ensembles.
*/
TclClockInit(interp);
/*
* Register the built-in functions. This is empty now that they are
* implemented as commands in the ::tcl::mathfunc namespace.
*/
/*
| > | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 |
/*
* Register "clock" subcommands. These *do* go through
* Tcl_CreateObjCommand, since they aren't in the global namespace and
* involve ensembles.
*/
TclClockInit(interp);
TclClockClassicInit(interp);
/*
* Register the built-in functions. This is empty now that they are
* implemented as commands in the ::tcl::mathfunc namespace.
*/
/*
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 |
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */
/*
* Register the builtin math functions.
*/
| | | 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */
/*
* Register the builtin math functions.
*/
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
|
| ︙ | ︙ | |||
3701 3702 3703 3704 3705 3706 3707 |
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
/* CallCommandTraces() does not cmdPtr, that's
* done just before Tcl_DeleteCommandFromToken() returns */
| | | 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 |
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
/* CallCommandTraces() does not cmdPtr, that's
* done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr, cmdPtr, NULL, NULL, TCL_TRACE_DELETE);
/*
* Now delete these traces.
*/
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
|
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 |
/*
* If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
* interp's result; otherwise, we leave it alone.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
| | | | | | | | | | | | | | | | | | | | | | | | | | 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 |
/*
* If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
* interp's result; otherwise, we leave it alone.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
const char *id, *message = NULL;
Tcl_Size length;
/*
* Setup errorCode variables so that we can differentiate between
* being canceled and unwound.
*/
if (iPtr->asyncCancelMsg != NULL) {
message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
} else {
length = 0;
}
if (iPtr->flags & TCL_CANCEL_UNWIND) {
id = "IUNWIND";
if (length == 0) {
message = "eval unwound";
}
} else {
id = "ICANCEL";
if (length == 0) {
message = "eval canceled";
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1));
Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (char *)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.
*/
|
| ︙ | ︙ | |||
4322 4323 4324 4325 4326 4327 4328 |
* cancellation request. Currently, clientData is ignored. If the
* TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
| | | 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 |
* cancellation request. Currently, clientData is ignored. If the
* TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)Tcl_Realloc(cancelInfo->result, cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
} else {
cancelInfo->result = NULL;
cancelInfo->length = 0;
}
|
| ︙ | ︙ | |||
4626 4627 4628 4629 4630 4631 4632 |
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
}
TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
| | > | 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 |
a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
}
TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
const char *a[6];
Tcl_Size i[2];
TclDTraceInfo(info, a, i);
TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
TclDecrRefCount(info);
}
if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED())
&& objc) {
|
| ︙ | ︙ | |||
4829 4830 4831 4832 4833 4834 4835 | /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the * type. */ listPtr = Tcl_NewListObj(objc, objv); | | | 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 |
/*
* If there was an error, a command string will be needed for the
* error log: get it out of the itemPtr. The details depend on the
* type.
*/
listPtr = Tcl_NewListObj(objc, objv);
cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
return result;
}
|
| ︙ | ︙ | |||
4975 4976 4977 4978 4979 4980 4981 |
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int traceCode = TCL_OK;
| | | 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 |
Tcl_Size objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int traceCode = TCL_OK;
const char *command = Tcl_GetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
* Execute any command or execution traces. Note that we bump up the
* command's reference count for the duration of the calling of the
* traces so that the structure doesn't go away underneath our feet.
*/
|
| ︙ | ︙ | |||
5027 5028 5029 5030 5031 5032 5033 |
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Tcl_Size length;
| | | 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 |
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
Tcl_Size objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Tcl_Size length;
const char *command = Tcl_GetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_DYING)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
|
| ︙ | ︙ | |||
6169 6170 6171 6172 6173 6174 6175 | * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); | | > > > > | 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 |
* both listPtr and objPtr.
*
* TODO: Create a test to demo this need, or eliminate it.
* FIXME OPT: preserve just the internal rep?
*/
Tcl_IncrRefCount(objPtr);
listPtr = TclDuplicatePureObj(interp, objPtr, tclListTypePtr);
if (!listPtr) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
Tcl_IncrRefCount(listPtr);
if (word != INT_MIN) {
/*
* TIP #280 Structures for tracking lines. As we know that this is
* dynamic execution we ignore the invoker, even if known.
*
|
| ︙ | ︙ | |||
6281 6282 6283 6284 6285 6286 6287 | assert(invoker == NULL); iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); Tcl_IncrRefCount(objPtr); | | | 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 |
assert(invoker == NULL);
iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr);
Tcl_IncrRefCount(objPtr);
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
iPtr->scriptCLLocPtr = saveCLLocPtr;
return result;
}
|
| ︙ | ︙ | |||
6312 6313 6314 6315 6316 6317 6318 |
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
| | | 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 |
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
/*
* We are returning to level 0, so should call TclResetCancellation.
* Let us just unset the flags inline.
*/
|
| ︙ | ︙ | |||
6843 6844 6845 6846 6847 6848 6849 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
Tcl_Size length;
| | | 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 |
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
Tcl_Size length;
const char *message = Tcl_GetStringFromObj(objPtr, &length);
Interp *iPtr = (Interp *) interp;
Tcl_IncrRefCount(objPtr);
/*
* If we are just starting to log an error, errorInfo is initialized from
* the error message in the interpreter's result.
|
| ︙ | ︙ | |||
7063 7064 7065 7066 7067 7068 7069 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7103 7104 7105 7106 7107 7108 7109 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7249 7250 7251 7252 7253 7254 7255 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7303 7304 7305 7306 7307 7308 7309 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
d = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
}
}
|
| ︙ | ︙ | |||
7367 7368 7369 7370 7371 7372 7373 |
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | | 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 |
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
d1 = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
}
}
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleTypePtr);
if (irPtr) {
d2 = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
}
}
|
| ︙ | ︙ | |||
7427 7428 7429 7430 7431 7432 7433 |
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
Tcl_Size numBytes;
| | | 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 |
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
Tcl_Size numBytes;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
while (numBytes) {
if (*bytes == '-') {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
bytes++;
|
| ︙ | ︙ | |||
7544 7545 7546 7547 7548 7549 7550 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
| | | 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
if (TclHasInternalRep(objv[1], tclDoubleTypePtr)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
#endif
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
|
| ︙ | ︙ | |||
8926 8927 8928 8929 8930 8931 8932 |
}
/*
* Perform the tailcall
*/
TclMarkTailcall(interp);
| | | 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 |
}
/*
* Perform the tailcall
*/
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL, NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc - 1, objv + 1, 0, NULL);
}
int
TclNRReleaseValues(
void *data[],
|
| ︙ | ︙ | |||
9109 9110 9111 9112 9113 9114 9115 |
void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
NRE_callback *rootPtr = TOP_CB(interp);
if (COR_IS_SUSPENDED(corPtr)) {
| | | 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 |
void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
NRE_callback *rootPtr = TOP_CB(interp);
if (COR_IS_SUSPENDED(corPtr)) {
TclNRRunCallbacks(interp, RewindCoroutine(corPtr, TCL_OK), rootPtr);
}
}
static int
NRCoroutineCallerCallback(
void *data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 |
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
| > | 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 |
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
|
| ︙ | ︙ | |||
9765 9766 9767 9768 9769 9770 9771 |
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
| | | 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 |
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr, &hSearch);
hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) {
int isNew;
Tcl_HashEntry *newPtr =
Tcl_CreateHashEntry(corPtr->lineLABCPtr,
Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr),
&isNew);
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * */ #include "tclInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
static const Tcl_ObjType properByteArrayType = {
"bytearray",
FreeProperByteArrayInternalRep,
DupProperByteArrayInternalRep,
UpdateStringOfByteArray,
NULL,
| < > > | | > | | 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 |
static const Tcl_ObjType properByteArrayType = {
"bytearray",
FreeProperByteArrayInternalRep,
DupProperByteArrayInternalRep,
UpdateStringOfByteArray,
NULL,
0
};
/*
* The following structure is the internal rep for a ByteArray object. Keeps
* track of how much memory has been used and how much has been allocated for
* the byte array to enable growing and shrinking of the ByteArray object with
* fewer mallocs.
*/
typedef struct {
Tcl_Size used; /* The number of bytes used in the byte
* array. */
Tcl_Size allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this
* field depends on the 'allocated' field
* above. */
} ByteArray;
#define BYTEARRAY_MAX_LEN \
(TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes))
#define BYTEARRAY_SIZE(len) \
( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \
? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \
: (offsetof(ByteArray, bytes) + (len)) )
#define GET_BYTEARRAY(irPtr) \
((ByteArray *) (irPtr)->twoPtrValue.ptr1)
#define SET_BYTEARRAY(irPtr, baPtr) \
(irPtr)->twoPtrValue.ptr1 = (baPtr)
int
TclIsPureByteArray(
Tcl_Obj * objPtr)
{
return TclHasInternalRep(objPtr, &properByteArrayType);
}
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
if (numBytesPtr != NULL) {
*numBytesPtr = baPtr->used;
}
return baPtr->bytes;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
if (numBytesPtr != NULL) {
*numBytesPtr = baPtr->used;
}
return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
*
* This procedure changes the length of the byte array for this object.
|
| ︙ | ︙ | |||
498 499 500 501 502 503 504 |
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size limit,
int demandProper,
ByteArray **byteArrayPtrPtr)
{
Tcl_Size length;
| | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size limit,
int demandProper,
ByteArray **byteArrayPtrPtr)
{
Tcl_Size length;
const char *src = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Size numBytes = (limit >= 0 && limit < length) ? limit : length;
ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes));
unsigned char *dst = byteArrayPtr->bytes;
unsigned char *dstEnd = dst + numBytes;
const char *srcEnd = src + length;
int proper = 1;
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
Tcl_Size len)
{
ByteArray *byteArrayPtr;
Tcl_Size needed;
Tcl_ObjInternalRep *irPtr;
if (Tcl_IsShared(objPtr)) {
| | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
Tcl_Size len)
{
ByteArray *byteArrayPtr;
Tcl_Size needed;
Tcl_ObjInternalRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "TclAppendBytesToByteArray");
}
if (len < 0) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
/*
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
Tcl_DecrRefCount(copy);
break;
}
case 'b':
case 'B': {
unsigned char *last;
| | | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 |
Tcl_DecrRefCount(copy);
break;
}
case 'b':
case 'B': {
unsigned char *last;
str = Tcl_GetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 7) / 8);
|
| ︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 |
break;
}
case 'h':
case 'H': {
unsigned char *last;
int c;
| | | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 |
break;
}
case 'h':
case 'H': {
unsigned char *last;
int c;
str = Tcl_GetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
last = cursor + ((count + 1) / 2);
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
/*
* Double-precision floating point values. Tcl_GetDoubleFromObj
* returns TCL_ERROR for NaN, but we can check by comparing the
* object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
| | | | | 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 |
/*
* Double-precision floating point values. Tcl_GetDoubleFromObj
* returns TCL_ERROR for NaN, but we can check by comparing the
* object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, tclDoubleTypePtr);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
return TCL_OK;
case 'f':
case 'r':
case 'R':
/*
* Single-precision floating point values. Tcl_GetDoubleFromObj
* returns TCL_ERROR for NaN, but we can check by comparing the
* object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, tclDoubleTypePtr);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
/*
* Because some compilers will generate floating point exceptions on
* an overflow cast (e.g. Borland), we restrict the values to the
* valid range for float.
*/
if (fabs(dvalue) > (double) FLT_MAX) {
if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) {
fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99
} else {
fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
}
} else {
fvalue = (float) dvalue;
}
CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
*cursorPtr += sizeof(float);
return TCL_OK;
|
| ︙ | ︙ | |||
2508 2509 2510 2511 2512 2513 2514 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *)Tcl_GetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
value = 0;
|
| ︙ | ︙ | |||
2582 2583 2584 2585 2586 2587 2588 | * Results: * The base64 encoded value prescribed by the input arguments. * *---------------------------------------------------------------------- */ #define OUTPUT(c) \ | | | | | | | | | | | | | | | 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 |
* Results:
* The base64 encoded value prescribed by the input arguments.
*
*----------------------------------------------------------------------
*/
#define OUTPUT(c) \
do { \
*cursor++ = (c); \
outindex++; \
if (maxlen > 0 && cursor != limit) { \
if (outindex == maxlen) { \
memcpy(cursor, wrapchar, wrapcharlen); \
cursor += wrapcharlen; \
outindex = 0; \
} \
} \
if (cursor > limit) { \
Tcl_Panic("limit hit"); \
} \
} while (0)
static int
BinaryEncode64(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
|
| ︙ | ︙ | |||
2642 2643 2644 2645 2646 2647 2648 |
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)Tcl_GetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
| | | 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 |
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)Tcl_GetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
|
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 | Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", (void *)NULL); return TCL_ERROR; } lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ break; case OPT_WRAPCHAR: | | > | | 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 |
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", (void *)NULL);
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
break;
case OPT_WRAPCHAR:
wrapchar = (const unsigned char *)Tcl_GetStringFromObj(
objv[i + 1], &wrapcharlen);
{
const unsigned char *p = wrapchar;
Tcl_Size numBytes = wrapcharlen;
while (numBytes) {
switch (*p) {
case '\t':
case '\v':
case '\f':
case '\r':
p++;
numBytes--;
continue;
case '\n':
numBytes--;
break;
default:
badwrap:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
lineLen = -1;
|
| ︙ | ︙ | |||
3087 3088 3089 3090 3091 3092 3093 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
| | | 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 |
}
}
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging * problems involving overwritten, double freeing memory and loss of * memory. * */ #include "tclInt.h" #include <assert.h> #define FALSE 0 #define TRUE 1 |
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
fprintf(stderr, "Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
fprintf(stderr, "Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs);
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
| | | | | 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 |
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "break_on_malloc") == 0) {
Tcl_WideInt value;
if (objc != 3) {
goto argError;
}
if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
break_on_malloc = value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "init") == 0) {
if (objc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(TclGetString(objv[2]), "on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "objs") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
| | | | | | | | | | 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 |
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "onexit") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName, fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "tag") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree(curTagPtr);
}
len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "trace") == 0) {
if (objc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(TclGetString(objv[2]), "on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "trace_on_at_malloc") == 0) {
Tcl_WideInt value;
if (objc != 3) {
goto argError;
}
if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
trace_on_at_malloc = value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "validate") == 0) {
if (objc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(TclGetString(objv[2]), "on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
|
| ︙ | ︙ |
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright © 1995 Sun Microsystems, Inc. * Copyright © 2004 Kevin B. Kenny. All rights reserved. * Copyright © 2015 Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" #include "tclStrIdxTree.h" #include "tclDate.h" /* | > > > > > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | * Copyright © 1995 Sun Microsystems, Inc. * Copyright © 2004 Kevin B. Kenny. All rights reserved. * Copyright © 2015 Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" #include "tclStrIdxTree.h" #include "tclDate.h" /* |
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
| | | 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasInternalRep(objv[1], tclBignumTypePtr)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/* Extract fields */
if (ClockGetDateFields(dataPtr, interp, &fields, objv[2],
|
| ︙ | ︙ | |||
3429 3430 3431 3432 3433 3434 3435 |
int idx;
if (Tcl_GetIndexFromObj(NULL, baseObj, nowOpts, "seconds",
TCL_EXACT, &idx) == TCL_OK) {
goto baseNow;
}
| | | | 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 |
int idx;
if (Tcl_GetIndexFromObj(NULL, baseObj, nowOpts, "seconds",
TCL_EXACT, &idx) == TCL_OK) {
goto baseNow;
}
if (TclHasInternalRep(baseObj, tclBignumTypePtr)) {
goto baseOverflow;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad seconds \"%s\": must be now or integer",
TclGetString(baseObj)));
i = baseIdx;
goto badOption;
}
/*
* Seconds could be an unsigned number that overflowed. Make sure
* that it isn't. Additionally it may be too complex to calculate
* julianday etc (forwards/backwards) by too large/small values, thus
* just let accept a bit shorter values to avoid overflow.
* Note the year is currently an integer, thus avoid to overflow it also.
*/
if (TclHasInternalRep(baseObj, tclBignumTypePtr)
|| baseVal < TCL_MIN_SECONDS || baseVal > TCL_MAX_SECONDS) {
baseOverflow:
Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]);
i = baseIdx;
goto badOption;
}
} else {
|
| ︙ | ︙ | |||
4426 4427 4428 4429 4430 4431 4432 |
continue;
}
/* get unit */
if (Tcl_GetIndexFromObj(interp, objv[i + 1], units, "unit", 0,
&unitIndex) != TCL_OK) {
goto done;
}
| | | 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 |
continue;
}
/* get unit */
if (Tcl_GetIndexFromObj(interp, objv[i + 1], units, "unit", 0,
&unitIndex) != TCL_OK) {
goto done;
}
if (TclHasInternalRep(objv[i], tclBignumTypePtr)
|| offs > (unitIndex < CLC_ADD_HOURS ? 0x7fffffff : TCL_MAX_SECONDS)
|| offs < (unitIndex < CLC_ADD_HOURS ? -0x7fffffff : TCL_MIN_SECONDS)) {
Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]);
goto done;
}
/* nothing to do if zero quantity */
|
| ︙ | ︙ |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 |
/*
* Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright © 1995 Sun Microsystems, Inc.
* Copyright © 2004 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclClockClassic.c --
*
* Contains the time and date related commands. This code is derived from
* the time and date facilities of TclX, by Mark Diekhans and Karl
* Lehenbauer.
*/
#include "tclInt.h"
#include "tclTomMath.h"
/*
* Windows has mktime. The configurators do not check.
*/
#ifdef _WIN32
#define HAVE_MKTIME 1
#endif
/*
* Constants
*/
#define JULIAN_DAY_POSIX_EPOCH 2440588
#define SECONDS_PER_DAY 86400
#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
* SECONDS_PER_DAY)
#define FOUR_CENTURIES 146097 /* days */
#define JDAY_1_JAN_1_CE_JULIAN 1721424
#define JDAY_1_JAN_1_CE_GREGORIAN 1721426
#define ONE_CENTURY_GREGORIAN 36524 /* days */
#define FOUR_YEARS 1461 /* days */
#define ONE_YEAR 365 /* days */
/*
* Table of the days in each month, leap and common years
*/
static const int daysInPriorMonths[2][13] = {
{0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365},
{0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366}
};
/*
* Enumeration of the string literals used in [clock]
*/
typedef enum ClockLiteral {
LIT__NIL,
LIT__DEFAULT_FORMAT,
LIT_BCE, LIT_C,
LIT_CANNOT_USE_GMT_AND_TIMEZONE,
LIT_CE,
LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR,
LIT_ERA, LIT_GMT, LIT_GREGORIAN,
LIT_INTEGER_VALUE_TOO_LARGE,
LIT_ISO8601WEEK, LIT_ISO8601YEAR,
LIT_JULIANDAY, LIT_LOCALSECONDS,
LIT_MONTH,
LIT_SECONDS, LIT_TZNAME, LIT_TZOFFSET,
LIT_YEAR,
LIT__END
} ClockLiteral;
static const char *const literals[] = {
"",
"%a %b %d %H:%M:%S %Z %Y",
"BCE", "C",
"cannot use -gmt and -timezone in same call",
"CE",
"dayOfMonth", "dayOfWeek", "dayOfYear",
"era", ":GMT", "gregorian",
"integer value too large to represent",
"iso8601Week", "iso8601Year",
"julianDay", "localSeconds",
"month",
"seconds", "tzName", "tzOffset",
"year"
};
/*
* Structure containing the client data for [clock]
*/
typedef struct {
size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
/*
* Structure containing the fields used in [clock format] and [clock scan]
*/
typedef struct {
Tcl_WideInt seconds; /* Time expressed in seconds from the Posix
* epoch */
Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds
* from the Posix epoch */
int tzOffset; /* Time zone offset in seconds east of
* Greenwich */
Tcl_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
int isBce; /* 1 if BCE */
int gregorian; /* Flag == 1 if the date is Gregorian */
int year; /* Year of the era */
int dayOfYear; /* Day of the year (1 January == 1) */
int month; /* Month number */
int dayOfMonth; /* Day of the month */
int iso8601Year; /* ISO8601 week-based year */
int iso8601Week; /* ISO8601 week number */
int dayOfWeek; /* Day of the week */
} TclDateFields;
static const char *const eras[] = { "CE", "BCE", NULL };
/*
* Thread specific data block holding a 'struct tm' for the 'gmtime' and
* 'localtime' library calls.
*/
static Tcl_ThreadDataKey tmKey;
/*
* Mutex protecting 'gmtime', 'localtime' and 'mktime' calls and the statics
* in the date parsing code.
*/
TCL_DECLARE_MUTEX(clockMutex)
/*
* Function prototypes for local procedures in this file:
*/
static int ConvertUTCToLocal(Tcl_Interp *,
TclDateFields *, Tcl_Obj *, int);
static int ConvertUTCToLocalUsingTable(Tcl_Interp *,
TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int ConvertUTCToLocalUsingC(Tcl_Interp *,
TclDateFields *, int);
static int ConvertLocalToUTC(Tcl_Interp *,
TclDateFields *, Tcl_Obj *, int);
static int ConvertLocalToUTCUsingTable(Tcl_Interp *,
TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int ConvertLocalToUTCUsingC(Tcl_Interp *,
TclDateFields *, int);
static Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
Tcl_Size, Tcl_Obj *const *);
static void GetYearWeekDay(TclDateFields *, int);
static void GetGregorianEraYearDay(TclDateFields *, int);
static void GetMonthDay(TclDateFields *);
static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int);
static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int);
static int IsGregorianLeapYear(TclDateFields *);
static Tcl_WideInt WeekdayOnOrBefore(int, Tcl_WideInt);
static Tcl_ObjCmdProc ClockClicksObjCmd;
static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd;
static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd;
static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd;
static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd;
static Tcl_ObjCmdProc ClockGetenvObjCmd;
static Tcl_ObjCmdProc ClockMicrosecondsObjCmd;
static Tcl_ObjCmdProc ClockMillisecondsObjCmd;
static Tcl_ObjCmdProc ClockParseformatargsObjCmd;
static Tcl_ObjCmdProc ClockSecondsObjCmd;
static struct tm * ThreadSafeLocalTime(const time_t *);
static void TzsetIfNecessary(void);
static void ClockDeleteCmdProc(void *);
/*
* Structure containing description of "native" clock commands to create.
*/
struct ClockCommand {
const char *name; /* The tail of the command name. The full name
* is "<clockns>::<name>". When NULL marks
* the end of the table. */
Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
* will always have the ClockClientData sent
* to it, but may well ignore this data. */
};
static const struct ClockCommand clockCommands[] = {
{"getenv", ClockGetenvObjCmd},
{"Oldscan", TclClockOldscanObjCmd},
{"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd},
{"GetDateFields", ClockGetdatefieldsObjCmd},
{"GetJulianDayFromEraYearMonthDay",
ClockGetjuliandayfromerayearmonthdayObjCmd},
{"GetJulianDayFromEraYearWeekDay",
ClockGetjuliandayfromerayearweekdayObjCmd},
{"ParseFormatArgs", ClockParseformatargsObjCmd},
{NULL, NULL}
};
/*
*----------------------------------------------------------------------
*
* TclClockClassicInit --
*
* Registers the 'clock' subcommands with the Tcl interpreter and
* initializes its client data (which consists mostly of constant
* Tcl_Obj's that it is too much trouble to keep recreating).
*
* Results:
* None.
*
* Side effects:
* Installs the commands and creates the client data
*
*----------------------------------------------------------------------
*/
void
TclClockClassicInit(
Tcl_Interp *interp) /* Tcl interpreter */
{
const struct ClockCommand *clockCmdPtr;
char cmdName[57]; /* Buffer large enough to hold the string
*::tcl::clock::classic::GetJulianDayFromEraYearMonthDay
* plus a terminating NUL. */
ClockClientData *data;
int i;
/* Structure of the 'clock' ensemble */
static const EnsembleImplMap clockImplMap[] = {
{"add", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0},
{"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
{"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0},
{"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
{"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
{"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* Safe interps get [::clock] as alias to a parent, so do not need their
* own copies of the support routines.
*/
if (Tcl_IsSafe(interp)) {
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
data->literals[i] = Tcl_NewStringObj(literals[i], -1);
Tcl_IncrRefCount(data->literals[i]);
}
/*
* Install the commands.
* TODO - Let Tcl_MakeEnsemble do this?
*/
#define TCL_CLOCK_PREFIX_LEN 23 /* == strlen("::tcl::clock::classic::") */
memcpy(cmdName, "::tcl::clock::classic::", TCL_CLOCK_PREFIX_LEN);
for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
data->refCount++;
Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data,
ClockDeleteCmdProc);
}
/* Make the clock ensemble */
TclMakeEnsemble(interp, "::tcl::clock::classic", clockImplMap);
}
/*
*----------------------------------------------------------------------
*
* ClockConvertlocaltoutcObjCmd --
*
* Tcl command that converts a UTC time to a local time by whatever means
* is available.
*
* Usage:
* ConvertUTCToLocal dictionary tzdata changeover
*
* Parameters:
* dict - Dictionary containing a 'localSeconds' entry.
* tzdata - Time zone data
* changeover - Julian Day of the adoption of the Gregorian calendar.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* On success, sets the interpreter result to the given dictionary
* augmented with a 'seconds' field giving the UTC time. On failure,
* leaves an error message in the interpreter result.
*
*----------------------------------------------------------------------
*/
static int
ClockConvertlocaltoutcObjCmd(
void *clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
int status;
/*
* Check params and convert time.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
return TCL_ERROR;
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, data->literals[LIT_LOCALSECONDS],
&secondsObj)!= TCL_OK) {
return TCL_ERROR;
}
if (secondsObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
"found in dictionary", -1));
return TCL_ERROR;
}
if ((TclGetWideIntFromObj(interp, secondsObj,
&fields.localSeconds) != TCL_OK)
|| (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
|| ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
return TCL_ERROR;
}
/*
* Copy-on-write; set the 'seconds' field in the dictionary and place the
* modified dictionary in the interpreter result.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
status = Tcl_DictObjPut(interp, dict, data->literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
Tcl_DecrRefCount(dict);
}
return status;
}
/*
*----------------------------------------------------------------------
*
* ClockGetdatefieldsObjCmd --
*
* Tcl command that determines the values that [clock format] will use in
* formatting a date, and populates a dictionary with them.
*
* Usage:
* GetDateFields seconds tzdata changeover
*
* Parameters:
* seconds - Time expressed in seconds from the Posix epoch.
* tzdata - Time zone data of the time zone in which time is to be
* expressed.
* changeover - Julian Day Number at which the current locale adopted
* the Gregorian calendar
*
* Results:
* Returns a dictonary populated with the fields:
* seconds - Seconds from the Posix epoch
* localSeconds - Nominal seconds from the Posix epoch in the
* local time zone.
* tzOffset - Time zone offset in seconds east of Greenwich
* tzName - Time zone name
* julianDay - Julian Day Number in the local time zone
*
*----------------------------------------------------------------------
*/
static int
ClockGetdatefieldsObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
/*
* Check params.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover");
return TCL_ERROR;
}
if (TclGetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK
|| TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
return TCL_ERROR;
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasInternalRep(objv[1], tclBignumTypePtr)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/*
* Convert UTC time to local.
*/
if (ConvertUTCToLocal(interp, &fields, objv[2], changeover) != TCL_OK) {
return TCL_ERROR;
}
/*
* Extract Julian day. Always round the quotient down by subtracting 1
* when the remainder is negative (i.e. if the quotient was rounded up).
*/
fields.julianDay = (int) ((fields.localSeconds / SECONDS_PER_DAY) -
((fields.localSeconds % SECONDS_PER_DAY) < 0) +
JULIAN_DAY_POSIX_EPOCH);
/*
* Convert to Julian or Gregorian calendar.
*/
GetGregorianEraYearDay(&fields, changeover);
GetMonthDay(&fields);
GetYearWeekDay(&fields, changeover);
dict = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, dict, lit[LIT_LOCALSECONDS],
Tcl_NewWideIntObj(fields.localSeconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET],
Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN],
Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, lit[LIT_ERA],
lit[fields.isBce ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR],
Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR],
Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH],
Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH],
Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR],
Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ClockGetjuliandayfromerayearmonthdayObjCmd --
*
* Tcl command that converts a time from era-year-month-day to a Julian
* Day Number.
*
* Parameters:
* dict - Dictionary that contains 'era', 'year', 'month' and
* 'dayOfMonth' keys.
* changeover - Julian Day of changeover to the Gregorian calendar
*
* Results:
* Result is either TCL_OK, with the interpreter result being the
* dictionary augmented with a 'julianDay' key, or TCL_ERROR,
* with the result being an error message.
*
*----------------------------------------------------------------------
*/
static int
FetchEraField(
Tcl_Interp *interp,
Tcl_Obj *dict,
Tcl_Obj *key,
int *storePtr)
{
Tcl_Obj *value = NULL;
if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) {
return TCL_ERROR;
}
if (value == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"expected key(s) not found in dictionary", -1));
return TCL_ERROR;
}
return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr);
}
static int
FetchIntField(
Tcl_Interp *interp,
Tcl_Obj *dict,
Tcl_Obj *key,
int *storePtr)
{
Tcl_Obj *value = NULL;
if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) {
return TCL_ERROR;
}
if (value == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"expected key(s) not found in dictionary", -1));
return TCL_ERROR;
}
return TclGetIntFromObj(interp, value, storePtr);
}
static int
ClockGetjuliandayfromerayearmonthdayObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFMONTH],
&fields.dayOfMonth) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearMonthDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return status;
}
/*
*----------------------------------------------------------------------
*
* ClockGetjuliandayfromerayearweekdayObjCmd --
*
* Tcl command that converts a time from the ISO calendar to a Julian Day
* Number.
*
* Parameters:
* dict - Dictionary that contains 'era', 'iso8601Year', 'iso8601Week'
* and 'dayOfWeek' keys.
* changeover - Julian Day of changeover to the Gregorian calendar
*
* Results:
* Result is either TCL_OK, with the interpreter result being the
* dictionary augmented with a 'julianDay' key, or TCL_ERROR, with the
* result being an error message.
*
*----------------------------------------------------------------------
*/
static int
ClockGetjuliandayfromerayearweekdayObjCmd(
void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601YEAR],
&fields.iso8601Year) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601WEEK],
&fields.iso8601Week) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFWEEK],
&fields.dayOfWeek) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearWeekDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
return status;
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTC --
*
* Converts a time (in a TclDateFields structure) from the local wall
* clock to UTC.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Populates the 'seconds' field if successful; stores an error message
* in the interpreter result on failure.
*
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
*/
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'mktime' to convert the time to local
*/
if (rowc == 0) {
return ConvertLocalToUTCUsingC(interp, fields, changeover);
} else {
return ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv);
}
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTCUsingTable --
*
* Converts a time (in a TclDateFields structure) from local time in a
* given time zone to UTC.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Stores an error message in the interpreter if an error occurs; if
* successful, stores the 'seconds' field in 'fields.
*
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
Tcl_Size rowc, /* Number of points at which time changes */
Tcl_Obj *const rowv[]) /* Points at which time changes */
{
Tcl_Obj *row;
Tcl_Size cellc;
Tcl_Obj **cellv;
int have[8];
int nHave = 0;
int i;
int found;
/*
* Perform an initial lookup assuming that local == UTC, and locate the
* last time conversion prior to that time. Get the offset from that row,
* and look up again. Continue until we find an offset that we found
* before. This definition, rather than "the same offset" ensures that we
* don't enter an endless loop, as would otherwise happen when trying to
* convert a non-existent time such as 02:30 during the US Spring Daylight
* Saving Time transition.
*/
found = 0;
fields->tzOffset = 0;
fields->seconds = fields->localSeconds;
while (!found) {
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if ((row == NULL)
|| TclListObjGetElements(interp, row, &cellc,
&cellv) != TCL_OK
|| TclGetIntFromObj(interp, cellv[1],
&fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
found = 0;
for (i = 0; !found && i < nHave; ++i) {
if (have[i] == fields->tzOffset) {
found = 1;
break;
}
}
if (!found) {
if (nHave == 8) {
Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
}
have[nHave++] = fields->tzOffset;
}
fields->seconds = fields->localSeconds - fields->tzOffset;
}
fields->tzOffset = have[i];
fields->seconds = fields->localSeconds - fields->tzOffset;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertLocalToUTCUsingC --
*
* Converts a time from local wall clock to UTC when the local time zone
* cannot be determined. Uses 'mktime' to do the job.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Stores an error message in the interpreter if an error occurs; if
* successful, stores the 'seconds' field in 'fields.
*
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTCUsingC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
struct tm timeVal;
int localErrno;
int secondOfDay;
Tcl_WideInt jsec;
/*
* Convert the given time to a date.
*/
jsec = fields->localSeconds + JULIAN_SEC_POSIX_EPOCH;
fields->julianDay = (int) (jsec / SECONDS_PER_DAY);
secondOfDay = (int)(jsec % SECONDS_PER_DAY);
if (secondOfDay < 0) {
secondOfDay += SECONDS_PER_DAY;
fields->julianDay--;
}
GetGregorianEraYearDay(fields, changeover);
GetMonthDay(fields);
/*
* Convert the date/time to a 'struct tm'.
*/
timeVal.tm_year = fields->year - 1900;
timeVal.tm_mon = fields->month - 1;
timeVal.tm_mday = fields->dayOfMonth;
timeVal.tm_hour = (secondOfDay / 3600) % 24;
timeVal.tm_min = (secondOfDay / 60) % 60;
timeVal.tm_sec = secondOfDay % 60;
timeVal.tm_isdst = -1;
timeVal.tm_wday = -1;
timeVal.tm_yday = -1;
/*
* Get local time. It is rumored that mktime is not thread safe on some
* platforms, so seize a mutex before attempting this.
*/
TzsetIfNecessary();
Tcl_MutexLock(&clockMutex);
errno = 0;
fields->seconds = (Tcl_WideInt) mktime(&timeVal);
localErrno = (fields->seconds == -1) ? errno : 0;
Tcl_MutexUnlock(&clockMutex);
/*
* 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;
}
/*
*----------------------------------------------------------------------
*
* ConvertUTCToLocal --
*
* Converts a time (in a TclDateFields structure) from UTC to local time.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Populates the 'tzName' and 'tzOffset' fields.
*
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocal(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
/*
* Unpack the tz data.
*/
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'localtime' to convert the time to local
*/
if (rowc == 0) {
return ConvertUTCToLocalUsingC(interp, fields, changeover);
} else {
return ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv);
}
}
/*
*----------------------------------------------------------------------
*
* ConvertUTCToLocalUsingTable --
*
* Converts UTC to local time, given a table of transition points
*
* Results:
* Returns a standard Tcl result
*
* Side effects:
* On success, fills fields->tzName, fields->tzOffset and
* fields->localSeconds. On failure, places an error message in the
* interpreter result.
*
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
Tcl_Size rowc, /* Number of rows in the conversion table
* (>= 1) */
Tcl_Obj *const rowv[]) /* Rows of the conversion table */
{
Tcl_Obj *row; /* Row containing the current information */
Tcl_Size cellc; /* Count of cells in the row (must be 4) */
Tcl_Obj **cellv; /* Pointers to the cells */
/*
* Look up the nearest transition time.
*/
row = LookupLastTransition(interp, fields->seconds, rowc, rowv);
if (row == NULL ||
TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK ||
TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
return TCL_ERROR;
}
/*
* Convert the time.
*/
fields->tzName = cellv[3];
Tcl_IncrRefCount(fields->tzName);
fields->localSeconds = fields->seconds + fields->tzOffset;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ConvertUTCToLocalUsingC --
*
* Converts UTC to localtime in cases where the local time zone is not
* determinable, using the C 'localtime' function to do it.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* On success, fills fields->tzName, fields->tzOffset and
* fields->localSeconds. On failure, places an error message in the
* interpreter result.
*
*----------------------------------------------------------------------
*/
static int
ConvertUTCToLocalUsingC(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
char buffer[16]; /* Buffer for time zone name */
/*
* 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", (char *)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", (char *)NULL);
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
fields->isBce = 0;
fields->year = timeVal->tm_year + 1900;
fields->month = timeVal->tm_mon + 1;
fields->dayOfMonth = timeVal->tm_mday;
GetJulianDayFromEraYearMonthDay(fields, changeover);
/*
* Convert that value to seconds.
*/
fields->localSeconds = (((fields->julianDay * (Tcl_WideInt) 24
+ timeVal->tm_hour) * 60 + timeVal->tm_min) * 60
+ timeVal->tm_sec) - JULIAN_SEC_POSIX_EPOCH;
/*
* Determine a time zone offset and name; just use +hhmm for the name.
*/
diff = (int) (fields->localSeconds - fields->seconds);
fields->tzOffset = diff;
if (diff < 0) {
*buffer = '-';
diff = -diff;
} else {
*buffer = '+';
}
snprintf(buffer+1, sizeof(buffer) - 1, "%02d", diff / 3600);
diff %= 3600;
snprintf(buffer+3, sizeof(buffer) - 3, "%02d", diff / 60);
diff %= 60;
if (diff > 0) {
snprintf(buffer+5, sizeof(buffer) - 5, "%02d", diff);
}
fields->tzName = Tcl_NewStringObj(buffer, -1);
Tcl_IncrRefCount(fields->tzName);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* LookupLastTransition --
*
* Given a UTC time and a tzdata array, looks up the last transition on
* or before the given time.
*
* Results:
* Returns a pointer to the row, or NULL if an error occurs.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
LookupLastTransition(
Tcl_Interp *interp, /* Interpreter for error messages */
Tcl_WideInt tick, /* Time from the epoch */
Tcl_Size rowc, /* Number of rows of tzdata */
Tcl_Obj *const *rowv) /* Rows in tzdata */
{
Tcl_Size l, u;
Tcl_Obj *compObj;
Tcl_WideInt compVal;
/*
* Examine the first row to make sure we're in bounds.
*/
if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK
|| TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
/*
* Bizarre case - first row doesn't begin at MIN_WIDE_INT. Return it
* anyway.
*/
if (tick < compVal) {
return rowv[0];
}
/*
* Binary-search to find the transition.
*/
l = 0;
u = rowc-1;
while (l < u) {
Tcl_Size m = (l + u + 1) / 2;
if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK ||
TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
if (tick >= compVal) {
l = m;
} else {
u = m-1;
}
}
return rowv[l];
}
/*
*----------------------------------------------------------------------
*
* GetYearWeekDay --
*
* Given a date with Julian Calendar Day, compute the year, week, and day
* in the ISO8601 calendar.
*
* Results:
* None.
*
* Side effects:
* Stores 'iso8601Year', 'iso8601Week' and 'dayOfWeek' in the date
* fields.
*
*----------------------------------------------------------------------
*/
static void
GetYearWeekDay(
TclDateFields *fields, /* Date to convert, must have 'julianDay' */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
TclDateFields temp;
int dayOfFiscalYear;
/*
* Find the given date, minus three days, plus one year. That date's
* iso8601 year is an upper bound on the ISO8601 year of the given date.
*/
temp.julianDay = fields->julianDay - 3;
GetGregorianEraYearDay(&temp, changeover);
if (temp.isBce) {
temp.iso8601Year = temp.year - 1;
} else {
temp.iso8601Year = temp.year + 1;
}
temp.iso8601Week = 1;
temp.dayOfWeek = 1;
GetJulianDayFromEraYearWeekDay(&temp, changeover);
/*
* temp.julianDay is now the start of an ISO8601 year, either the one
* corresponding to the given date, or the one after. If we guessed high,
* move one year earlier
*/
if (fields->julianDay < temp.julianDay) {
if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
}
GetJulianDayFromEraYearWeekDay(&temp, changeover);
}
fields->iso8601Year = temp.iso8601Year;
dayOfFiscalYear = fields->julianDay - temp.julianDay;
fields->iso8601Week = (dayOfFiscalYear / 7) + 1;
fields->dayOfWeek = (dayOfFiscalYear + 1) % 7;
if (fields->dayOfWeek < 1) {
fields->dayOfWeek += 7;
}
}
/*
*----------------------------------------------------------------------
*
* GetGregorianEraYearDay --
*
* Given a Julian Day Number, extracts the year and day of the year and
* puts them into TclDateFields, along with the era (BCE or CE) and a
* flag indicating whether the date is Gregorian or Julian.
*
* Results:
* None.
*
* Side effects:
* Stores 'era', 'gregorian', 'year', and 'dayOfYear'.
*
*----------------------------------------------------------------------
*/
static void
GetGregorianEraYearDay(
TclDateFields *fields, /* Date fields containing 'julianDay' */
int changeover) /* Gregorian transition date */
{
Tcl_WideInt jday = fields->julianDay;
Tcl_WideInt day;
Tcl_WideInt year;
Tcl_WideInt n;
if (jday >= changeover) {
/*
* Gregorian calendar.
*/
fields->gregorian = 1;
year = 1;
/*
* n = Number of 400-year cycles since 1 January, 1 CE in the
* proleptic Gregorian calendar. day = remaining days.
*/
day = jday - JDAY_1_JAN_1_CE_GREGORIAN;
n = day / FOUR_CENTURIES;
day %= FOUR_CENTURIES;
if (day < 0) {
day += FOUR_CENTURIES;
n--;
}
year += 400 * n;
/*
* n = number of centuries since the start of (year);
* day = remaining days
*/
n = day / ONE_CENTURY_GREGORIAN;
day %= ONE_CENTURY_GREGORIAN;
if (n > 3) {
/*
* 31 December in the last year of a 400-year cycle.
*/
n = 3;
day += ONE_CENTURY_GREGORIAN;
}
year += 100 * n;
} else {
/*
* Julian calendar.
*/
fields->gregorian = 0;
year = 1;
day = jday - JDAY_1_JAN_1_CE_JULIAN;
}
/*
* n = number of 4-year cycles; days = remaining days.
*/
n = day / FOUR_YEARS;
day %= FOUR_YEARS;
if (day < 0) {
day += FOUR_YEARS;
n--;
}
year += 4 * n;
/*
* n = number of years; days = remaining days.
*/
n = day / ONE_YEAR;
day %= ONE_YEAR;
if (n > 3) {
/*
* 31 December of a leap year.
*/
n = 3;
day += 365;
}
year += n;
/*
* store era/year/day back into fields.
*/
if (year <= 0) {
fields->isBce = 1;
fields->year = 1 - year;
} else {
fields->isBce = 0;
fields->year = year;
}
fields->dayOfYear = day + 1;
}
/*
*----------------------------------------------------------------------
*
* GetMonthDay --
*
* Given a date as year and day-of-year, find month and day.
*
* Results:
* None.
*
* Side effects:
* Stores 'month' and 'dayOfMonth' in the 'fields' structure.
*
*----------------------------------------------------------------------
*/
static void
GetMonthDay(
TclDateFields *fields) /* Date to convert */
{
int day = fields->dayOfYear;
int month;
const int *dipm = daysInPriorMonths[IsGregorianLeapYear(fields)];
/*
* Estimate month by calculating `dayOfYear / (365/12)`
*/
month = (day*12) / dipm[12];
/* then do forwards backwards correction */
while (1) {
if (day > dipm[month]) {
if (month >= 11 || day <= dipm[month+1]) {
break;
}
month++;
} else {
if (month == 0) {
break;
}
month--;
}
}
day -= dipm[month];
fields->month = month+1;
fields->dayOfMonth = day;
}
/*
*----------------------------------------------------------------------
*
* GetJulianDayFromEraYearWeekDay --
*
* Given a TclDateFields structure containing era, ISO8601 year, ISO8601
* week, and day of week, computes the Julian Day Number.
*
* Results:
* None.
*
* Side effects:
* Stores 'julianDay' in the fields.
*
*----------------------------------------------------------------------
*/
static void
GetJulianDayFromEraYearWeekDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Julian Day Number of the Gregorian
* transition */
{
Tcl_WideInt firstMonday; /* Julian day number of week 1, day 1 in the
* given year */
TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
firstWeek.dayOfMonth = 4;
GetJulianDayFromEraYearMonthDay(&firstWeek, changeover);
/*
* Find Monday of week 1.
*/
firstMonday = WeekdayOnOrBefore(1, firstWeek.julianDay);
/*
* Advance to the given week and day.
*/
fields->julianDay = firstMonday + 7 * (fields->iso8601Week - 1)
+ fields->dayOfWeek - 1;
}
/*
*----------------------------------------------------------------------
*
* GetJulianDayFromEraYearMonthDay --
*
* Given era, year, month, and dayOfMonth (in TclDateFields), and the
* Gregorian transition date, computes the Julian Day Number.
*
* Results:
* None.
*
* Side effects:
* Stores day number in 'julianDay'
*
*----------------------------------------------------------------------
*/
static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
Tcl_WideInt year, ym1, ym1o4, ym1o100, ym1o400;
int month, mm1, q, r;
if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
}
/*
* Reduce month modulo 12.
*/
month = fields->month;
mm1 = month - 1;
q = mm1 / 12;
r = (mm1 % 12);
if (r < 0) {
r += 12;
q -= 1;
}
year += q;
month = r + 1;
ym1 = year - 1;
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
fields->isBce = 1;
fields->year = 1-year;
} else {
fields->isBce = 0;
fields->year = year;
}
/*
* Try an initial conversion in the Gregorian calendar.
*/
#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */
ym1o4 = ym1 / 4;
#else
/*
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
if (ym1 >= 0) {
ym1o4 = ym1 / 4;
} else {
ym1o4 = - (int) (((unsigned int) -ym1) / 4);
}
#endif
if (ym1 % 4 < 0) {
ym1o4--;
}
ym1o100 = ym1 / 100;
if (ym1 % 100 < 0) {
ym1o100--;
}
ym1o400 = ym1 / 400;
if (ym1 % 400 < 0) {
ym1o400--;
}
fields->julianDay = JDAY_1_JAN_1_CE_GREGORIAN - 1
+ fields->dayOfMonth
+ daysInPriorMonths[IsGregorianLeapYear(fields)][month - 1]
+ (ONE_YEAR * ym1)
+ ym1o4
- ym1o100
+ ym1o400;
/*
* If the resulting date is before the Gregorian changeover, convert in
* the Julian calendar instead.
*/
if (fields->julianDay < changeover) {
fields->gregorian = 0;
fields->julianDay = JDAY_1_JAN_1_CE_JULIAN - 1
+ fields->dayOfMonth
+ daysInPriorMonths[year%4 == 0][month - 1]
+ (365 * ym1)
+ ym1o4;
}
}
/*
*----------------------------------------------------------------------
*
* IsGregorianLeapYear --
*
* Tests whether a given year is a leap year, in either Julian or
* Gregorian calendar.
*
* Results:
* Returns 1 for a leap year, 0 otherwise.
*
*----------------------------------------------------------------------
*/
static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
Tcl_WideInt year = fields->year;
if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
return 0;
} else if (!(fields->gregorian)) {
return 1;
} else if (year%400 == 0) {
return 1;
} else if (year%100 == 0) {
return 0;
} else {
return 1;
}
}
/*
*----------------------------------------------------------------------
*
* WeekdayOnOrBefore --
*
* Finds the Julian Day Number of a given day of the week that falls on
* or before a given date, expressed as Julian Day Number.
*
* Results:
* Returns the Julian Day Number
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
WeekdayOnOrBefore(
int dayOfWeek, /* Day of week; Sunday == 0 or 7 */
Tcl_WideInt julianDay) /* Reference date */
{
int k = (dayOfWeek + 6) % 7;
if (k < 0) {
k += 7;
}
return julianDay - ((julianDay - k) % 7);
}
/*
*----------------------------------------------------------------------
*
* ClockGetenvObjCmd --
*
* Tcl command that reads an environment variable from the system
*
* Usage:
* getEnv NAME
*
* Parameters:
* NAME - Name of the environment variable desired
*
* Results:
* Returns a standard Tcl result. Returns an error if the variable does
* not exist, with a message left in the interpreter. Returns TCL_OK and
* the value of the variable if the variable does exist,
*
*----------------------------------------------------------------------
*/
static int
ClockGetenvObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
#ifdef _WIN32
const WCHAR *varName;
const WCHAR *varValue;
Tcl_DString ds;
#else
const char *varName;
const char *varValue;
#endif
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
#ifdef _WIN32
Tcl_DStringInit(&ds);
varName = Tcl_UtfToWCharDString(TclGetString(objv[1]), -1, &ds);
varValue = _wgetenv(varName);
if (varValue == NULL) {
Tcl_DStringFree(&ds);
} else {
Tcl_DStringSetLength(&ds, 0);
Tcl_WCharToUtfDString(varValue, -1, &ds);
Tcl_DStringResult(interp, &ds);
}
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
if (varValue != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
}
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSafeLocalTime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
static struct tm *
ThreadSafeLocalTime(
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm *tmPtr = (struct tm *)Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
tmPtr = localtime_r(timePtr, tmPtr);
#else
struct tm *sysTmPtr;
Tcl_MutexLock(&clockMutex);
sysTmPtr = localtime(timePtr);
if (sysTmPtr == NULL) {
Tcl_MutexUnlock(&clockMutex);
return NULL;
}
memcpy(tmPtr, sysTmPtr, sizeof(struct tm));
Tcl_MutexUnlock(&clockMutex);
#endif
return tmPtr;
}
/*----------------------------------------------------------------------
*
* ClockClicksObjCmd --
*
* Returns a high-resolution counter.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
* This function implements the 'clock clicks' Tcl command. Refer to the user
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
static int
ClockClicksObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
static const char *const clicksSwitches[] = {
"-milliseconds", "-microseconds", NULL
};
enum ClicksSwitch {
CLICKS_MILLIS, CLICKS_MICROS, CLICKS_NATIVE
};
int index = CLICKS_NATIVE;
Tcl_Time now;
Tcl_WideInt clicks = 0;
switch (objc) {
case 1:
break;
case 2:
if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
break;
default:
Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
return TCL_ERROR;
}
switch (index) {
case CLICKS_MILLIS:
Tcl_GetTime(&now);
clicks = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000;
break;
case CLICKS_NATIVE:
#ifdef TCL_WIDE_CLICKS
clicks = TclpGetWideClicks();
#else
clicks = (Tcl_WideInt)TclpGetClicks();
#endif
break;
case CLICKS_MICROS:
clicks = TclpGetMicroseconds();
break;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks));
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockMillisecondsObjCmd -
*
* Returns a count of milliseconds since the epoch.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
* This function implements the 'clock milliseconds' Tcl command. Refer to the
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
static int
ClockMillisecondsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)
now.sec * 1000 + now.usec / 1000);
Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
/*----------------------------------------------------------------------
*
* ClockMicrosecondsObjCmd -
*
* Returns a count of microseconds since the epoch.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
* This function implements the 'clock microseconds' Tcl command. Refer to the
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
static int
ClockMicrosecondsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* ClockParseformatargsObjCmd --
*
* Parses the arguments for [clock format].
*
* Results:
* Returns a standard Tcl result, whose value is a four-element list
* comprising the time format, the locale, and the timezone.
*
* This function exists because the loop that parses the [clock format]
* options is a known performance "hot spot", and is implemented in an effort
* to speed that particular code up.
*
*-----------------------------------------------------------------------------
*/
static int
ClockParseformatargsObjCmd(
void *clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj **litPtr = dataPtr->literals;
Tcl_Obj *results[3]; /* Format, locale and timezone */
#define formatObj results[0]
#define localeObj results[1]
#define timezoneObj results[2]
int gmtFlag = 0;
static const char *const options[] = { /* Command line options expected */
"-format", "-gmt", "-locale",
"-timezone", NULL };
enum optionInd {
CLOCK_FORMAT_FORMAT, CLOCK_FORMAT_GMT, CLOCK_FORMAT_LOCALE,
CLOCK_FORMAT_TIMEZONE
};
int optionIndex; /* Index of an option. */
int saw = 0; /* Flag == 1 if option was seen already. */
Tcl_WideInt clockVal; /* Clock value - just used to parse. */
int i;
/*
* Args consist of a time followed by keyword-value pairs.
*/
if (objc < 2 || (objc % 2) != 0) {
Tcl_WrongNumArgs(interp, 0, objv,
"clock format clockval ?-format string? "
"?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?");
Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
return TCL_ERROR;
}
/*
* Extract values for the keywords.
*/
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
TclGetString(objv[i]), (char *)NULL);
return TCL_ERROR;
}
switch (optionIndex) {
case CLOCK_FORMAT_FORMAT:
formatObj = objv[i+1];
break;
case CLOCK_FORMAT_GMT:
if (Tcl_GetBooleanFromObj(interp, objv[i+1], &gmtFlag) != TCL_OK){
return TCL_ERROR;
}
break;
case CLOCK_FORMAT_LOCALE:
localeObj = objv[i+1];
break;
case CLOCK_FORMAT_TIMEZONE:
timezoneObj = objv[i+1];
break;
}
saw |= 1 << optionIndex;
}
/*
* Check options.
*/
if (TclGetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
return TCL_ERROR;
}
if ((saw & (1 << CLOCK_FORMAT_GMT))
&& (saw & (1 << CLOCK_FORMAT_TIMEZONE))) {
Tcl_SetObjResult(interp, litPtr[LIT_CANNOT_USE_GMT_AND_TIMEZONE]);
Tcl_SetErrorCode(interp, "CLOCK", "gmtWithTimezone", (char *)NULL);
return TCL_ERROR;
}
if (gmtFlag) {
timezoneObj = litPtr[LIT_GMT];
}
/*
* Return options as a list.
*/
Tcl_SetObjResult(interp, Tcl_NewListObj(3, results));
return TCL_OK;
#undef timezoneObj
#undef localeObj
#undef formatObj
}
/*----------------------------------------------------------------------
*
* ClockSecondsObjCmd -
*
* Returns a count of microseconds since the epoch.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* None.
*
* This function implements the 'clock seconds' Tcl command. Refer to the user
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
static int
ClockSecondsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec);
Tcl_SetObjResult(interp, timeObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TzsetIfNecessary --
*
* Calls the tzset() library function if the contents of the TZ
* environment variable has changed.
*
* Results:
* None.
*
* Side effects:
* Calls tzset.
*
*----------------------------------------------------------------------
*/
#ifdef _WIN32
#define getenv(x) _wgetenv(L##x)
#else
#define WCHAR char
#define wcslen strlen
#define wcscmp strcmp
#define wcscpy strcpy
#endif
static void
TzsetIfNecessary(void)
{
static WCHAR* tzWas = (WCHAR *)INT2PTR(-1); /* Previous value of TZ, protected by
* clockMutex. */
static long long tzLastRefresh = 0; /* Used for latency before next refresh */
static size_t tzEnvEpoch = 0; /* Last env epoch, for faster signaling,
that TZ changed via TCL */
const WCHAR *tzIsNow; /* Current value of TZ */
/*
* Prevent performance regression on some platforms by resolving of system time zone:
* small latency for check whether environment was changed (once per second)
* no latency if environment was changed with tcl-env (compare both epoch values)
*/
Tcl_Time now;
Tcl_GetTime(&now);
if (now.sec == tzLastRefresh && tzEnvEpoch == TclEnvEpoch) {
return;
}
tzEnvEpoch = TclEnvEpoch;
tzLastRefresh = now.sec;
Tcl_MutexLock(&clockMutex);
tzIsNow = getenv("TZ");
if (tzIsNow != NULL && (tzWas == NULL || tzWas == (WCHAR *)INT2PTR(-1)
|| wcscmp(tzIsNow, tzWas) != 0)) {
tzset();
if (tzWas != NULL && tzWas != (WCHAR *)INT2PTR(-1)) {
Tcl_Free(tzWas);
}
tzWas = (WCHAR *)Tcl_Alloc(sizeof(WCHAR) * (wcslen(tzIsNow) + 1));
wcscpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
if (tzWas != (WCHAR *)INT2PTR(-1)) {
Tcl_Free(tzWas);
}
tzWas = NULL;
}
Tcl_MutexUnlock(&clockMutex);
}
/*
*----------------------------------------------------------------------
*
* ClockDeleteCmdProc --
*
* Remove a reference to the clock client data, and clean up memory
* when it's all gone.
*
* Results:
* None.
*
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
void *clientData) /* Opaque pointer to the client data */
{
ClockClientData *data = (ClockClientData *)clientData;
int i;
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
Tcl_Free(data->literals);
Tcl_Free(data);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclClockFmt.c -- * * Contains the date format (and scan) routines. This code is back-ported * from the time and date facilities of tclSE engine, by Serg G. Brester. * * Copyright (c) 2015 by Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclStrIdxTree.h" #include "tclDate.h" /* * Miscellaneous forward declarations and functions used within this file | > > > > > > > > > | 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 | /* * tclClockFmt.c -- * * Contains the date format (and scan) routines. This code is back-ported * from the time and date facilities of tclSE engine, by Serg G. Brester. * * Copyright (c) 2015 by Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclStrIdxTree.h" #include "tclDate.h" /* * Miscellaneous forward declarations and functions used within this file |
| ︙ | ︙ | |||
641 642 643 644 645 646 647 |
static const Tcl_ObjType ClockFmtObjType = {
"clock-format", /* name */
ClockFmtObj_FreeInternalRep, /* freeIntRepProc */
ClockFmtObj_DupInternalRep, /* dupIntRepProc */
ClockFmtObj_UpdateString, /* updateStringProc */
ClockFmtObj_SetFromAny, /* setFromAnyProc */
| < > | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
static const Tcl_ObjType ClockFmtObjType = {
"clock-format", /* name */
ClockFmtObj_FreeInternalRep, /* freeIntRepProc */
ClockFmtObj_DupInternalRep, /* dupIntRepProc */
ClockFmtObj_UpdateString, /* updateStringProc */
ClockFmtObj_SetFromAny, /* setFromAnyProc */
0
};
#define ObjClockFmtScn(objPtr) \
(*((ClockFmtScnStorage **)&(objPtr)->internalRep.twoPtrValue.ptr1))
#define ObjLocFmtKey(objPtr) \
(*((Tcl_Obj **)&(objPtr)->internalRep.twoPtrValue.ptr2))
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * 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. */ #include "tclInt.h" #include "tclIO.h" #include "tclTomMath.h" #ifdef _WIN32 # include "tclWinInt.h" #endif |
| ︙ | ︙ | |||
401 402 403 404 405 406 407 | } /* *------------------------------------------------------------------------ * * EncodingConvertParseOptions -- * | | | | | | | | | | | | | 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 |
}
/*
*------------------------------------------------------------------------
*
* EncodingConvertParseOptions --
*
* Common routine for parsing arguments passed to encoding convertfrom
* and encoding convertto.
*
* Results:
* TCL_OK or TCL_ERROR.
*
* Side effects:
* On success,
* - *encPtr is set to the encoding. Must be freed with Tcl_FreeEncoding
* if non-NULL
* - *dataObjPtr is set to the Tcl_Obj containing the data to encode or
* decode
* - *profilePtr is set to encoding error handling profile
* - *failVarPtr is set to -failindex option value or NULL
* On error, all of the above are uninitialized.
*
*------------------------------------------------------------------------
*/
static int
EncodingConvertParseOptions(
Tcl_Interp *interp, /* For error messages. May be NULL */
int objc, /* Number of arguments */
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
Tcl_Size length = 0; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
int flags;
int result;
Tcl_Obj *failVarObj;
Tcl_Size errorLocation;
if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data,
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
return TCL_ERROR;
}
/*
* Convert the string to a byte array in 'ds'
*/
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
return TCL_ERROR;
}
/*
* Convert the string to a byte array in 'ds'
*/
stringPtr = Tcl_GetStringFromObj(data, &length);
result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags,
&ds, failVarObj ? &errorLocation : NULL);
/* NOTE: ds must be freed beyond this point even on error */
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
|
| ︙ | ︙ | |||
2062 2063 2064 2065 2066 2067 2068 |
{
Tcl_Obj *res;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
| | | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 |
{
Tcl_Obj *res;
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",
(char *)NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
| | | | | | | > | 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 |
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
DOBJPUT("nlink",Tcl_NewWideIntObj((long)statPtr->st_nlink));
DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
DOBJPUT("atime",Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
DOBJPUT("mtime",Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
DOBJPUT("ctime",Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
DOBJPUT("mode", Tcl_NewWideIntObj(mode));
DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), TCL_AUTO_LENGTH));
#undef DOBJPUT
Tcl_SetObjResult(interp, result);
Tcl_DecrRefCount(result);
return TCL_OK;
}
/*
* Might be a better idea to call Tcl_SetVar2Ex() instead, except we want
* to have an object (i.e. possibly cached) array variable name but a
* string element name, so no API exists. Messy.
*/
#define STORE_ARY(fieldName, object) \
TclNewLiteralStringObj(field, fieldName); \
Tcl_IncrRefCount(field); \
value = (object); \
if (Tcl_ObjSetVar2(interp, varName, field, value, \
TCL_LEAVE_ERR_MSG) == NULL) { \
TclDecrRefCount(field); \
return TCL_ERROR; \
} \
TclDecrRefCount(field);
/*
* Watch out porters; the inode is meant to be an *unsigned* value, so the
|
| ︙ | ︙ | |||
2803 2804 2805 2806 2807 2808 2809 |
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
/* List */
/* Variables */
| | > | | 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 |
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
/* List */
/* Variables */
statePtr->vCopyList[i] = TclDuplicatePureObj(
interp, objv[1+i*2], tclListTypePtr);
if (!statePtr->vCopyList[i]) {
result = TCL_ERROR;
goto done;
}
result = TclListObjLength(interp, statePtr->vCopyList[i],
&statePtr->varcList[i]);
if (result != TCL_OK) {
result = TCL_ERROR;
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 | result = TCL_ERROR; goto done; } TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ | | | > > | > > > > < | > | | 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 |
result = TCL_ERROR;
goto done;
}
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
/* Values */
if (TclObjectHasInterface(objv[2+i*2], list, length)) {
int status;
statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
Tcl_IncrRefCount(statePtr->aCopyList[i]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
/* Don't compute values here, wait until the last moment */
TclObjectDispatchNoDefault(interp, status, statePtr->aCopyList[i], list,
length, interp, statePtr->aCopyList[i], &statePtr->argcList[i]);
if (status != TCL_OK) {
result = TCL_ERROR;
goto done;
}
} else {
statePtr->aCopyList[i] = TclDuplicatePureObj(
interp, objv[2+i*2], tclListTypePtr);
if (!statePtr->aCopyList[i]) {
result = TCL_ERROR;
goto done;
}
result = TclListObjGetElements(interp, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
if (result != TCL_OK) {
goto done;
|
| ︙ | ︙ | |||
2977 2978 2979 2980 2981 2982 2983 |
struct ForeachState *statePtr)
{
int i;
Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
| | > | < | > | > | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 |
struct ForeachState *statePtr)
{
int i;
Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
int status;
int hasindexinterface = TclObjectHasInterface(
statePtr->aCopyList[i], list, index);
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
if (hasindexinterface) {
status = TclObjectDispatchNoDefault(interp, status, statePtr->aCopyList[i], list,
index, interp, statePtr->aCopyList[i], k, &valuePtr);
if (status != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (setting %s loop variable \"%s\")",
(statePtr->resultList != NULL ? "lmap" : "foreach"),
TclGetString(statePtr->varvList[i][v])));
return TCL_ERROR;
}
} else {
|
| ︙ | ︙ |
1 | /* | < < < < < < < > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1993-1997 Lucent Technologies. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclCmdIL.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters I through L. It * contains only commands in the generic core (i.e., those that don't * depend much upon UNIX facilities). */ #include "tclInt.h" #include "tclRegexp.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* |
| ︙ | ︙ | |||
559 560 561 562 563 564 565 |
* bytecompiled - in that case, the return was a copy of the body's string
* rep. In order to better isolate the implementation details of the
* compiler/engine subsystem, we now always return a copy of the string
* rep. It is important to return a copy so that later manipulations of
* the object do not invalidate the internal rep.
*/
| | | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 |
* bytecompiled - in that case, the return was a copy of the body's string
* rep. In order to better isolate the implementation details of the
* compiler/engine subsystem, we now always return a copy of the string
* rep. It is important to return a copy so that later manipulations of
* the object do not invalidate the internal rep.
*/
bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
| | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 |
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
Tcl_Obj *
TclInfoFrame(
Tcl_Interp *interp, /* Current interpreter. */
CmdFrame *framePtr) /* Frame to get info for. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *tmpObj;
| | | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 |
Tcl_Obj *
TclInfoFrame(
Tcl_Interp *interp, /* Current interpreter. */
CmdFrame *framePtr) /* Frame to get info for. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *tmpObj;
Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to
* the dict. */
int lc = 0;
/*
* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
static const char *const typeString[TCL_LOCATION_LAST] = {
|
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 |
/*
* Pull the information and construct the dictionary to return, as list.
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
*/
#define ADD_PAIR(name, value) \
| | | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
/*
* Pull the information and construct the dictionary to return, as list.
* Regarding use of the CmdFrame fields see tclInt.h, and its definition.
*/
#define ADD_PAIR(name, value) \
TclNewLiteralStringObj(tmpObj, name); \
lv[lc++] = tmpObj; \
lv[lc++] = (value)
switch (framePtr->type) {
case TCL_LOCATION_EVAL:
/*
* Evaluation, dynamic script. Type, line, cmd, the latter through
* str.
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
Tcl_JoinObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
| | | | | < | | | > > > > | > > | | | | | | > | | > > > > > > | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 |
Tcl_JoinObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
int status;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs = NULL;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
if (TclObjectHasInterface(objv[1], list, length)) {
status = TclObjectDispatchNoDefault(interp, status, objv[1], list,
length, interp, objv[1], &listLen);
if (status != TCL_OK ) {
return TCL_ERROR;
}
} else if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
if (listLen == 0) {
/* No elements to join; default empty result is correct. */
return TCL_OK;
}
if (listLen == 1) {
Tcl_Obj *valueObj;
/* One element; return it */
if (TclObjectHasInterface(objv[1], list, index)) {
TclObjectDispatchNoDefault(interp, status, objv[1], list,
index, interp, objv[1], 0, &valueObj);
if (status != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valueObj);
} else {
if (elemPtrs == NULL) {
if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, elemPtrs[0]);
}
return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
(void)Tcl_GetStringFromObj(joinObjPtr, &length);
if (length == 0) {
if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
Tcl_Size i;
TclNewObj(resObjPtr);
if (TclObjectHasInterface(objv[1], list, index)) {
Tcl_Obj *valueObj;
for (i = 0; i < listLen; i++) {
if (i > 0) {
/*
* NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
* to shimmer joinObjPtr. If it did, then the case where
* objv[1] and objv[2] are the same value would not be safe.
* Accessing elemPtrs would crash.
*/
Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
}
TclObjectDispatchNoDefault(interp, status, objv[1], list,
index, interp, objv[1], i, &valueObj);
if (status != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendObjToObj(resObjPtr, valueObj);
TclBounceRefCount(valueObj);
}
} else {
if (elemPtrs == NULL) {
if (TclListObjGetElements(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
}
for (i = 0; i < listLen; i++) {
if (i > 0) {
/*
* NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
* to shimmer joinObjPtr. If it did, then the case where
* objv[1] and objv[2] are the same value would not be safe.
* Accessing elemPtrs would crash.
*/
Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
}
Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
}
}
Tcl_DecrRefCount(joinObjPtr);
if (resObjPtr) {
Tcl_SetObjResult(interp, resObjPtr);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2259 2260 2261 2262 2263 2264 2265 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
Tcl_Size listObjc; /* The length of the list. */
Tcl_Size origListObjc; /* Original length */
| | | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
Tcl_Size listObjc; /* The length of the list. */
Tcl_Size origListObjc; /* Original length */
int i, status;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2323 2324 2325 2326 2327 2328 2329 |
return TCL_ERROR;
}
}
Tcl_DecrRefCount(emptyObj);
}
if (listObjc > 0) {
| | | | | > | | | | | | 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 |
return TCL_ERROR;
}
}
Tcl_DecrRefCount(emptyObj);
}
if (listObjc > 0) {
Tcl_Obj *resultPtr = NULL;
Tcl_Size fromIdx = origListObjc - listObjc;
Tcl_Size toIdx = origListObjc - 1;
if (TclObjectHasInterface(listPtr, list, range)) {
TclObjectDispatchNoDefault(interp, status, listPtr, list, range,
interp, listPtr, fromIdx, toIdx, &resultPtr);
if (status != TCL_OK) {
return TCL_ERROR;
}
} else {
status = TclListObjRange(interp, listPtr,
origListObjc - listObjc, origListObjc - 1, &resultPtr);
if (status != TCL_OK || resultPtr == NULL) {
return status;
}
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2423 2424 2425 2426 2427 2428 2429 |
*----------------------------------------------------------------------
*/
int
Tcl_LinsertObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
*----------------------------------------------------------------------
*/
int
Tcl_LinsertObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
Tcl_Size len, index;
int copied = 0, result;
if (objc < 3) {
|
| ︙ | ︙ | |||
2461 2462 2463 2464 2465 2466 2467 |
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
| > | > > | 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 |
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
|
| ︙ | ︙ | |||
2516 2517 2518 2519 2520 2521 2522 |
*----------------------------------------------------------------------
*/
int
Tcl_ListObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | < | 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 |
*----------------------------------------------------------------------
*/
int
Tcl_ListObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
* Otherwise set the interpreter's result object to be a list object.
*/
if (objc > 1) {
|
| ︙ | ︙ | |||
2553 2554 2555 2556 2557 2558 2559 |
*/
int
Tcl_LlengthObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
| | < | 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 |
*/
int
Tcl_LlengthObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size listLen;
int result;
Tcl_Obj *objPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
|
| ︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 |
*/
int
Tcl_LpopObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
| | < | | 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 |
*/
int
Tcl_LpopObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size listLen;
int copied = 0, result, status;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 |
}
}
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount(elemPtr);
/*
* Second, remove the element.
| < > | > > < < < < | < | < < < | < | 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 |
}
}
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount(elemPtr);
/*
* Second, remove the element.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
if (result != TCL_OK) {
if (copied) {
Tcl_DecrRefCount(listPtr);
}
return result;
}
} else {
Tcl_Obj *newListPtr;
status = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL, &newListPtr);
if (status != TCL_OK || newListPtr == NULL) {
return status;
} else {
listPtr = newListPtr;
}
}
stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
if (stored == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 |
*/
int
Tcl_LrangeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
| | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | < < | | < < | < < < < < | | 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 |
*/
int
Tcl_LrangeObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int result, status;
Tcl_Size fromAnchor, first, fromIdx, last, listLen, toAnchor, toIdx;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ TCL_SIZE_MAX - 1,
&toIdx);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ TCL_SIZE_MAX - 1,
&fromIdx);
if (result != TCL_OK) {
return result;
}
toAnchor = TclIndexIsFromEnd(toIdx);
fromAnchor = TclIndexIsFromEnd(fromIdx);
if (!Tcl_LengthIsFinite(listLen)
&& (toAnchor == 1 || fromAnchor == 1)
&& TclObjectHasInterface(objv[1], list, rangeEnd)
) {
Tcl_Obj *objResultPtr;
status = TclObjectInterfaceCall(objv[1], list, rangeEnd,
interp, objv[1], toAnchor, toIdx, fromAnchor, fromIdx,
&objResultPtr);
if (status != TCL_OK || objResultPtr == NULL) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, objResultPtr);
}
} else {
Tcl_Obj *resultPtr;
result = TclGetIntForIndexM(interp, objv[2], /*endValue*/ listLen - 1,
&first);
if (result != TCL_OK) {
return result;
}
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result != TCL_OK) {
return result;
}
status = TclListObjRange(interp, objv[1], first, last, &resultPtr);
if (status != TCL_OK || resultPtr == NULL) {
return status;
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2852 2853 2854 2855 2856 2857 2858 |
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
| > | > > > | 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 |
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
listObj = TclDuplicatePureObj(interp, listObj, tclListTypePtr);
if (!listObj) {
status = TCL_ERROR;
goto done;
}
copied = 1;
}
num = 0;
first = listLen;
for (i = 0, prevIdx = -1 ; i < idxc ; i++) {
Tcl_Size idx = idxv[i];
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
*----------------------------------------------------------------------
*/
int
Tcl_LrepeatObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
| | | < | < | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_LrepeatObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size elementCount, i, totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
* lrepeat count ?value ...?
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetSizeIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad count \"%" TCL_SIZE_MODIFIER "d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
(char *)NULL);
return TCL_ERROR;
}
/*
* Skip forward to the interesting arguments now we've finished parsing.
|
| ︙ | ︙ | |||
3092 3093 3094 3095 3096 3097 3098 |
first = listLen;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
| | > | > > | 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 |
first = listLen;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
/*
* If the list object is unshared we can modify it directly, otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
if (!listPtr) {
return TCL_ERROR;
}
}
/*
* Note that we call Tcl_ListObjReplace even when numToDelete == 0 and
* objc == 4. In this case, the list value of listPtr is not changed (no
* elements are removed or added), but by making the call we are assured
* we end up with a list in canonical form. Resist any temptation to
|
| ︙ | ︙ | |||
3161 3162 3163 3164 3165 3166 3167 |
Tcl_Size elemc, i, j;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
| < < < < | > | > > > > | > > | | > | | < | 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 |
Tcl_Size elemc, i, j;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
if (TclObjectHasInterface(objv[1], list, reverse)) {
int status;
Tcl_Obj *resObj;
if (Tcl_IsShared(objv[1])) {
resObj = Tcl_DuplicateObj(objv[1]);
} else {
resObj = objv[1];
}
TclObjectDispatchNoDefault(interp, status, resObj, list,
reverse, interp, resObj);
if (status == TCL_OK) {
Tcl_SetObjResult(interp, resObj);
}
return status;
}
if (TclListObjLength(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the list is empty, just return it. [Bug 1876793]
|
| ︙ | ︙ | |||
3259 3260 3261 3262 3263 3264 3265 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
int match, result=TCL_OK, bisect;
Tcl_Size i, length = 0, listc, elemLen, start, index;
| | | | | 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
int match, result=TCL_OK, bisect;
Tcl_Size i, length = 0, listc, elemLen, start, index;
Tcl_Size groupSize, groupOffset, lower, upper;
int allocatedIndexVector = 0;
int isIncreasing;
Tcl_WideInt patWide, objWide, wide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, *itemPtr, *item2Ptr, *listPtr, *subjectPtr, *startPtr;
SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
"-real", "-regexp", "-sorted", "-start", "-stride",
|
| ︙ | ︙ | |||
3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 |
enum modes mode;
mode = GLOB;
dataType = ASCII;
isIncreasing = 1;
allMatches = 0;
inlineReturn = 0;
returnSubindices = 0;
negatedMatch = 0;
bisect = 0;
listPtr = NULL;
startPtr = NULL;
groupSize = 1;
groupOffset = 0;
| > | 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 |
enum modes mode;
mode = GLOB;
dataType = ASCII;
isIncreasing = 1;
allMatches = 0;
inlineReturn = 0;
itemPtr = NULL;
returnSubindices = 0;
negatedMatch = 0;
bisect = 0;
listPtr = NULL;
startPtr = NULL;
groupSize = 1;
groupOffset = 0;
|
| ︙ | ︙ | |||
3563 3564 3565 3566 3567 3568 3569 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
| > | | 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 |
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
subjectPtr = objv[objc-2];
result = Tcl_ListObjLength(interp, subjectPtr, &listc);
if (result != TCL_OK) {
goto done;
}
/*
* Check for sanity when grouping elements of the overall list together
* because of the -stride option. [TIP #351]
|
| ︙ | ︙ | |||
3617 3618 3619 3620 3621 3622 3623 |
}
/*
* Get the user-specified start offset.
*/
if (startPtr) {
| | > | | > | < | > < < < | > < < | > > > | > | > > | > > | > > > > > > > > > > > > > > > > > > | < < > > | > > > > > > | | > > > | | 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 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 3843 3844 3845 3846 3847 3848 |
}
/*
* Get the user-specified start offset.
*/
if (startPtr) {
result = TclGetIntForIndexM(interp, startPtr,
(Tcl_LengthIsFinite(listc) ? listc - 1 : TCL_SIZE_MAX), &start);
if (result != TCL_OK) {
goto done;
}
if (start == TCL_INDEX_NONE) {
start = TCL_INDEX_START;
}
/*
* If the search started past the end of the list, just return a
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (Tcl_LengthIsFinite(listc) && start >= listc) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
TclNewIntObj(itemPtr, -1);
Tcl_SetObjResult(interp, itemPtr);
itemPtr = NULL;
}
goto done;
}
/*
* If start points within a group, it points to the start of the group.
*/
if (groupSize > 1) {
start -= (start % groupSize);
}
}
patObj = objv[objc - 1];
patternBytes = NULL;
if (mode == EXACT || mode == SORTED) {
switch (dataType) {
case ASCII:
case DICTIONARY:
patternBytes = Tcl_GetStringFromObj(patObj, &length);
break;
case INTEGER:
result = TclGetWideIntFromObj(interp, patObj, &patWide);
if (result != TCL_OK) {
goto done;
}
/*
* [Bug 1844789], "lsearch -exact -integer ..." crashes, was
* previously fixed at this point.
*/
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
goto done;
}
/*
* [Bug 1844789], "lsearch -exact -integer ..." crashes, was
* previously fixed at this point.
*/
break;
}
} else {
patternBytes = Tcl_GetStringFromObj(patObj, &length);
}
/*
* Set default index value to -1, indicating failure; if we find the item
* in the course of our search, index will be set to the correct value.
*/
index = -1;
match = 0;
if (mode == SORTED && !allMatches && !negatedMatch) {
int isfinite;
/*
* If the data is sorted, we can do a more intelligent search. Note
* that there is no point in being smart when -all was specified; in
* that case, we have to look at all items anyway, and there is no
* sense in doing this when the match sense is inverted.
*/
/*
* With -stride, lower, upper and i are kept as multiples of groupSize.
*/
lower = start - groupSize;
isfinite = Tcl_LengthIsFinite(listc);
if (isfinite) {
upper = listc;
} else {
upper = 1;
}
while (
(lower + groupSize < upper && sortInfo.resultCode == TCL_OK)
|| !isfinite
) {
i = (lower + upper) / 2;
if (i < 0) {
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_NewStringObj("sorted list is incoherent", -1));
goto done;
}
i -= i % groupSize;
result = Tcl_ListObjIndex(interp, subjectPtr, i+groupOffset, &itemPtr);
if (result != TCL_OK) {
if (isfinite) {
goto done;
} else {
if (Tcl_ListObjLength(interp, subjectPtr, &listc) == TCL_OK) {
isfinite = Tcl_LengthIsFinite(listc);
if (isfinite) {
if (listc - 1 > i) {
upper = listc = 1;
break;
} else {
goto done;
}
} else {
goto done;
}
} else {
goto done;
}
}
}
Tcl_IncrRefCount(itemPtr);
if (sortInfo.indexc != 0) {
item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
/* Increment item2Ptr refcount first in case it's the same
* object as itemPtr. */
Tcl_IncrRefCount(item2Ptr);
Tcl_DecrRefCount(itemPtr);
itemPtr = item2Ptr;
}
switch (dataType) {
case ASCII:
bytes = TclGetString(itemPtr);
match = strCmpFn(patternBytes, bytes);
break;
case DICTIONARY:
|
| ︙ | ︙ | |||
3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 |
} else if (patDouble < objDouble) {
match = -1;
} else {
match = 1;
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
| > > | 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 |
} else if (patDouble < objDouble) {
match = -1;
} else {
match = 1;
}
break;
}
Tcl_DecrRefCount(itemPtr);
itemPtr = NULL;
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
|
| ︙ | ︙ | |||
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 |
lower = i;
} else {
upper = i;
}
} else if (match > 0) {
if (isIncreasing) {
lower = i;
} else {
upper = i;
}
} else {
if (isIncreasing) {
upper = i;
} else {
lower = i;
}
}
}
if (bisect && index < 0) {
index = lower;
}
} else {
/*
* We need to do a linear search, because (at least one) of:
* - our matcher can only tell equal vs. not equal
* - our matching sense is negated
* - we're building a list of all matched items
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
| > > > > > > > > | | | > | > | | > > > | | | 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 |
lower = i;
} else {
upper = i;
}
} else if (match > 0) {
if (isIncreasing) {
lower = i;
if (!isfinite) {
upper *= 2;
}
} else {
upper = i;
isfinite = 1;
}
} else {
if (isIncreasing) {
upper = i;
isfinite = 1;
} else {
lower = i;
if (!isfinite) {
upper *= 2;
}
}
}
}
if (bisect && index < 0) {
index = lower;
}
} else {
/*
* We need to do a linear search, because (at least one) of:
* - our matcher can only tell equal vs. not equal
* - our matching sense is negated
* - we're building a list of all matched items
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
for (i = start; listc < 0 || i < listc; i += groupSize) {
match = 0;
result = Tcl_ListObjIndex(interp, subjectPtr, i+groupOffset, &itemPtr);
if (result != TCL_OK) {
goto done;
}
Tcl_IncrRefCount(itemPtr);
if (sortInfo.indexc != 0) {
item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
result = sortInfo.resultCode;
goto done;
}
/* Increment item2Ptr refcount first in case it's the same
* object as itemPtr. */
Tcl_IncrRefCount(item2Ptr);
Tcl_DecrRefCount(itemPtr);
itemPtr = item2Ptr;
}
switch (mode) {
case SORTED:
case EXACT:
switch (dataType) {
case ASCII:
bytes = Tcl_GetStringFromObj(itemPtr, &elemLen);
if (length == elemLen) {
/*
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
|
| ︙ | ︙ | |||
3869 3870 3871 3872 3873 3874 3875 | } goto done; } match = (objWide == patWide); break; case REAL: | | | 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 |
}
goto done;
}
match = (objWide == patWide);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, itemPtr, &objDouble);
if (result != TCL_OK) {
if (listPtr) {
Tcl_DecrRefCount(listPtr);
}
goto done;
}
match = (objDouble == patDouble);
|
| ︙ | ︙ | |||
3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 |
* Invert match condition for -not.
*/
if (negatedMatch) {
match = !match;
}
if (!match) {
continue;
}
if (!allMatches) {
index = i;
break;
} else if (inlineReturn) {
/*
| > > > > | > > > > > > | | < | > > > > > > > > | | > | | > > > | > > < < < > | | > > > > > | < > > > > > > > > > > | > > > > | > | | | > | 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 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 |
* Invert match condition for -not.
*/
if (negatedMatch) {
match = !match;
}
if (!match) {
Tcl_DecrRefCount(itemPtr);
itemPtr = NULL;
continue;
}
if (!allMatches) {
index = i;
Tcl_DecrRefCount(itemPtr);
itemPtr = NULL;
break;
} else if (inlineReturn) {
/*
* These append operations are expected to not fail.
*/
Tcl_DecrRefCount(itemPtr);
itemPtr = NULL;
if (returnSubindices && (sortInfo.indexc != 0)) {
result = Tcl_ListObjIndex(interp, subjectPtr, i+groupOffset, &itemPtr);
if (result != TCL_OK) {
goto done;
}
Tcl_IncrRefCount(itemPtr);
item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
Tcl_ListObjAppendElement(interp, listPtr, item2Ptr);
Tcl_DecrRefCount(itemPtr);
} else if (groupSize > 1) {
Tcl_Size j;
for (j = 0; j < groupSize; j++) {
result = Tcl_ListObjIndex(interp, subjectPtr,
i+j, &itemPtr);
if (result != TCL_OK) {
goto done;
}
Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
1, &itemPtr);
}
} else {
result = Tcl_ListObjIndex(interp, subjectPtr, i, &itemPtr);
if (result != TCL_OK) {
goto done;
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
Tcl_Size j;
Tcl_DecrRefCount(itemPtr);
TclNewIndexObj(itemPtr, i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
Tcl_Size elValue = TclIndexDecode(sortInfo.indexv[j], listc);
TclNewIndexObj(elObj, elValue);
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
Tcl_DecrRefCount(itemPtr);
Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
itemPtr = NULL;
}
}
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
if (returnSubindices) {
Tcl_Size j;
TclNewIndexObj(itemPtr, index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_Obj *elObj;
size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc);
TclNewIndexObj(elObj, elValue);
Tcl_ListObjAppendElement(interp, itemPtr, elObj);
}
Tcl_SetObjResult(interp, itemPtr);
itemPtr = NULL;
} else {
Tcl_Obj *elObj;
TclNewIndexObj(elObj, index);
Tcl_SetObjResult(interp, elObj);
}
} else if (index < 0) {
/*
* Is this superfluous? The result should be a blank object by
* default...
*/
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
if (returnSubindices) {
result = Tcl_ListObjIndex(interp, subjectPtr, i+groupOffset, &itemPtr);
if (result != TCL_OK) {
goto done;
}
item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
Tcl_SetObjResult(interp, item2Ptr);
} else if (groupSize > 1) {
Tcl_Size j;
listPtr = Tcl_NewListObj(0, NULL);
for (j = 0; j < groupSize; j++) {
result = Tcl_ListObjIndex(interp, subjectPtr, index + j, &itemPtr);
if (result != TCL_OK) {
Tcl_DecrRefCount(listPtr);
goto done;
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
Tcl_SetObjResult(interp, listPtr);
} else {
result = Tcl_ListObjIndex(interp, subjectPtr, index, &itemPtr);
if (result != TCL_OK) {
goto done;
}
Tcl_SetObjResult(interp, itemPtr);
}
itemPtr = NULL;
}
result = TCL_OK;
/*
* Cleanup the index list array.
*/
done:
if (itemPtr != NULL) {
Tcl_DecrRefCount(itemPtr);
}
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* SequenceIdentifyArgument --
* (for [lseq] command)
*
|
| ︙ | ︙ | |||
4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 |
"missing \"%s\" value.", TclGetString(argPtr)));
return ErrArg;
}
*keywordIndexPtr = opmode;
return RangeKeywordArg;
} else {
Tcl_Obj *exprValueObj;
if (!(allowedArgs & NumericArg)) {
return NoneArg;
}
doExpr:
/* Check for an index expression */
if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) {
return ErrArg;
}
| > < | 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 |
"missing \"%s\" value.", TclGetString(argPtr)));
return ErrArg;
}
*keywordIndexPtr = opmode;
return RangeKeywordArg;
} else {
Tcl_Obj *exprValueObj;
int keyword;
if (!(allowedArgs & NumericArg)) {
return NoneArg;
}
doExpr:
/* Check for an index expression */
if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) {
return ErrArg;
}
/* Determine if result of expression is double or int */
if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr,
&keyword) != TCL_OK
) {
return ErrArg;
}
*numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */
|
| ︙ | ︙ | |||
4216 4217 4218 4219 4220 4221 4222 |
step = one;
useDoubles = 0; // Can only have Integer value. If a fractional value
// is given, this will fail later. In other words,
// "3.0" is allowed and used as Integer, but "3.1"
// will be flagged as an error. (bug f4a4bd7f1070)
break;
| < | < | | | | < | 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 |
step = one;
useDoubles = 0; // Can only have Integer value. If a fractional value
// is given, this will fail later. In other words,
// "3.0" is allowed and used as Integer, but "3.1"
// will be flagged as an error. (bug f4a4bd7f1070)
break;
case 11: /* lseq n n */
start = numValues[0];
end = numValues[1];
break;
case 111: /* lseq n n n */
start = numValues[0];
end = numValues[1];
step = numValues[2];
break;
case 121: /* lseq n 'to' n
* lseq n 'count' n
* lseq n 'by' n */
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
break;
|
| ︙ | ︙ | |||
4255 4256 4257 4258 4259 4260 4261 | step = one; break; default: goto done; } break; | | | < | 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 |
step = one;
break;
default:
goto done;
}
break;
case 1211: /* lseq n 'to' n n
* lseq n 'count' n n */
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
step = numValues[3];
|
| ︙ | ︙ | |||
4281 4282 4283 4284 4285 4286 4287 | break; default: goto done; break; } break; | < | | | < | 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 |
break;
default:
goto done;
break;
}
break;
case 1121: /* lseq n n 'by' n */
start = numValues[0];
end = numValues[1];
opmode = (SequenceOperators)values[2];
switch (opmode) {
case LSEQ_BY:
step = numValues[3];
break;
case LSEQ_DOTS:
case LSEQ_TO:
case LSEQ_COUNT:
default:
goto done;
break;
}
break;
case 12121: /* lseq n 'to' n 'by' n
* lseq n 'count' n 'by' n */
start = numValues[0];
opmode = (SequenceOperators)values[3];
switch (opmode) {
case LSEQ_BY:
step = numValues[4];
break;
default:
|
| ︙ | ︙ | |||
4338 4339 4340 4341 4342 4343 4344 |
syntax:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
goto done;
break;
}
/* Count needs to be integer, so try to convert if possible */
| | | 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 |
syntax:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
goto done;
break;
}
/* Count needs to be integer, so try to convert if possible */
if (elementCount && TclHasInternalRep(elementCount, tclDoubleTypePtr)) {
double d;
// Don't consider Count type to indicate using double values in seqence
useDoubles -= (useDoubles > 0) ? 1 : 0;
(void)Tcl_GetDoubleFromObj(NULL, elementCount, &d);
if (floor(d) == d) {
if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) {
mp_int big;
|
| ︙ | ︙ | |||
4366 4367 4368 4369 4370 4371 4372 |
/*
* Success! Now lets create the series object.
*/
arithSeriesPtr = TclNewArithSeriesObj(interp,
useDoubles, start, end, step, elementCount);
| < > > > | 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 |
/*
* Success! Now lets create the series object.
*/
arithSeriesPtr = TclNewArithSeriesObj(interp,
useDoubles, start, end, step, elementCount);
if (arithSeriesPtr) {
status = TCL_OK;
Tcl_SetObjResult(interp, arithSeriesPtr);
} else {
status = TCL_ERROR;
}
done:
// Free number arguments.
while (--value_i>=0) {
if (numValues[value_i]) {
if (elementCount == numValues[value_i]) {
elementCount = NULL;
|
| ︙ | ︙ | |||
4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 |
/* Undef constants */
#undef zero
#undef one
return status;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsetObjCmd --
*
* This procedure is invoked to process the "lset" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
| > | > | 4553 4554 4555 4556 4557 4558 4559 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 |
/* Undef constants */
#undef zero
#undef one
return status;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsetObjCmd --
*
* This procedure is invoked to process the "lset" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
int status = TCL_OK;
/*
* Check parameter count.
*/
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
4447 4448 4449 4450 4451 4452 4453 |
* Substitute the value in the value. Return either the value or else an
* unshared copy of it.
*/
if (objc == 4) {
finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
} else {
| < < < < < < < | | < | < | | 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 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 |
* Substitute the value in the value. Return either the value or else an
* unshared copy of it.
*/
if (objc == 4) {
finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
} else {
status = TclLsetFlat(interp, listPtr, objc-3, objv+2,
objv[objc-1], &finalValuePtr);
}
/*
* If substitution has failed, bail out.
*/
if (status != TCL_OK || finalValuePtr == NULL) {
return TCL_ERROR;
}
/*
* Finally, update the variable so that traces fire.
*/
listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
/*
* Return the new value of the variable as the interpreter result.
*/
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
* user documentation for details on what it does.
|
| ︙ | ︙ | |||
4513 4514 4515 4516 4517 4518 4519 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int indices, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, allocatedIndexVector = 0;
| | | | 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int indices, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, allocatedIndexVector = 0;
Tcl_Size j, idx, groupSize, groupOffset, length;
Tcl_WideInt wide;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
Tcl_Size i, elmArrSize;
SortElement *elementArray = NULL, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
# define MAXCALLOC 1024000
# define NUM_LISTS 30
|
| ︙ | ︙ | |||
4729 4730 4731 4732 4733 4734 4735 | /* * When sorting using a command, we are reentrant and therefore might * have the representation of the list being sorted shimmered out from * underneath our feet. Take a copy (cheap) to prevent this. [Bug * 1675116] */ | | | 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 |
/*
* When sorting using a command, we are reentrant and therefore might
* have the representation of the list being sorted shimmered out from
* underneath our feet. Take a copy (cheap) to prevent this. [Bug
* 1675116]
*/
listObj = TclDuplicatePureObj(interp ,listObj, tclListTypePtr);
if (listObj == NULL) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
/*
* The existing command is a list. We want to flatten it, append two
|
| ︙ | ︙ | |||
4754 4755 4756 4757 4758 4759 4760 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
| | > | | | 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
if (TclObjectHasInterface(listObj, list, all)) {
TCL_UNUSEDVAR(int status);
sortInfo.resultCode = TclObjectDispatchNoDefault(interp, status,
listObj, list, all, interp, listObj, &length, &listObjPtrs);
} else {
sortInfo.resultCode = TclListObjGetElements(interp, listObj,
&length, &listObjPtrs);
}
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
|
| ︙ | ︙ | |||
4949 4950 4951 4952 4953 4954 4955 |
ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
ListObjGetRep(resultPtr, &listRep);
newArray = ListRepElementsBase(&listRep);
if (group) {
| | | 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 |
ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
ListObjGetRep(resultPtr, &listRep);
newArray = ListRepElementsBase(&listRep);
if (group) {
for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
idx = elementPtr->payload.index;
for (j = 0; j < groupSize; j++) {
if (indices) {
TclNewIndexObj(objPtr, idx + j - groupOffset);
newArray[i++] = objPtr;
Tcl_IncrRefCount(objPtr);
} else {
|
| ︙ | ︙ | |||
5077 5078 5079 5080 5081 5082 5083 |
first = listLen;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
| | > | > > | 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 |
first = listLen;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
if (!listPtr) {
return TCL_ERROR;
}
createdNewObj = 1;
} else {
createdNewObj = 0;
}
result =
Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc - 4, objv + 4);
|
| ︙ | ︙ |
1 | /* | < < < < < < < > > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2002 ActiveState Corporation. * Copyright © 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of the Tcl * built-in commands whose names begin with the letters M to Z. It * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). */ #include "tclInt.h" #include "tclCompile.h" #include "tclRegexp.h" #include "tclStringTrim.h" #include "tclTomMath.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); static Tcl_NRPostProc SwitchPostProc; static Tcl_NRPostProc TryPostBody; static Tcl_NRPostProc TryPostFinal; static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); static int StringCmpOpts(Tcl_Interp *interp, int objc, |
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
Tcl_Size splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
| | | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 |
Tcl_Size splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
TclNewObj(listPtr);
if (stringLen == 0) {
/*
* Do nothing.
*/
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 | /* * Handle the special case of splitting on a single character. This is * only true for the one-char ASCII case, as one Unicode char is > 1 * byte in length. */ | | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
/*
* Handle the special case of splitting on a single character. This is
* only true for the one-char ASCII case, as one Unicode char is > 1
* byte in length.
*/
while (*stringPtr && (p=strchr(stringPtr, *splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
stringPtr = p + 1;
}
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size start = TCL_INDEX_START;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
| | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size start = TCL_INDEX_START;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?startIndex?");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1;
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) {
|
| ︙ | ︙ | |||
1401 1402 1403 1404 1405 1406 1407 |
Tcl_Size index, end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
return TCL_ERROR;
}
| > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | > | 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 |
Tcl_Size index, end;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
return TCL_ERROR;
}
if (TclObjectHasInterface(objv[1], string, index)) {
int status;
Tcl_Obj *charPtr;
status = TclStringIndexInterface(interp, objv[1], objv[2], &charPtr) ;
if (status != TCL_OK) {
return status;
} else {
Tcl_SetObjResult(interp, charPtr);
return TCL_OK;
}
} else {
/*
* Get the char length to calculate what 'end' means.
*/
end = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index <= end)) {
int ch = Tcl_GetUniChar(objv[1], index);
if (ch == -1) {
return TCL_OK;
}
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
end = Tcl_UniCharToUtf(ch, buf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end));
}
}
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* StringInsertCmd --
*
|
| ︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 |
break;
case STR_IS_ASCII:
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
| | | | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 |
break;
case STR_IS_ASCII:
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
if (!TclHasInternalRep(objPtr, tclBooleanTypePtr)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
string1 = Tcl_GetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
} else if ((objPtr->internalRep.wideValue != 0)
? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) {
result = 0;
}
break;
|
| ︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 | * SetDictFromAny(). */ const char *elemStart, *nextElem; Tcl_Size lenRemain, elemSize; const char *p; | | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
* SetDictFromAny().
*/
const char *elemStart, *nextElem;
Tcl_Size lenRemain, elemSize;
const char *p;
string1 = Tcl_GetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
&elemStart, &nextElem, &elemSize, NULL)) {
Tcl_Obj *tmpStr;
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 |
}
break;
}
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
| | | | | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 |
}
break;
}
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
if (TclHasInternalRep(objPtr, tclDoubleTypePtr) ||
TclHasInternalRep(objPtr, tclIntTypePtr) ||
TclHasInternalRep(objPtr, tclBignumTypePtr)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
|
| ︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
case STR_IS_ENTIER:
| | | | | 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
case STR_IS_ENTIER:
if (TclHasInternalRep(objPtr, tclIntTypePtr) ||
TclHasInternalRep(objPtr, tclBignumTypePtr)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
|
| ︙ | ︙ | |||
1752 1753 1754 1755 1756 1757 1758 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
| | | 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
}
break;
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
result = 0;
|
| ︙ | ︙ | |||
1821 1822 1823 1824 1825 1826 1827 | */ const char *elemStart, *nextElem; Tcl_Size lenRemain; Tcl_Size elemSize; const char *p; | | | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
*/
const char *elemStart, *nextElem;
Tcl_Size lenRemain;
Tcl_Size elemSize;
const char *p;
string1 = Tcl_GetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
&elemStart, &nextElem, &elemSize, NULL)) {
Tcl_Obj *tmpStr;
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
break;
case STR_IS_XDIGIT:
chcomp = UniCharIsHexDigit;
break;
}
if (chcomp != NULL) {
| | | 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 |
break;
case STR_IS_XDIGIT:
chcomp = UniCharIsHexDigit;
break;
}
if (chcomp != NULL) {
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
| | | | 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 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
const char *string = Tcl_GetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", 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, (char *)NULL);
return TCL_ERROR;
}
}
/*
* This test is tricky, but has to be that way or you get other strange
* inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (!TclHasStringRep(objv[objc-2])
&& TclHasInternalRep(objv[objc-2], tclDictTypePtr)) {
Tcl_Size i;
int done;
Tcl_DictSearch search;
/*
* We know the type exactly, so all dict operations will succeed for
* sure. This shortens this code quite a bit.
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size length;
| | | 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 |
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size length;
const char *string = Tcl_GetStringFromObj(objv[1], &length);
if ((length > 1) && strncmp(string, "-nocase", 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",
|
| ︙ | ︙ | |||
2403 2404 2405 2406 2407 2408 2409 |
/*
* The following test screens out most empty substrings as candidates for
* replacement. When they are detected, no replacement is done, and the
* result is the original string.
*/
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
/*
* The following test screens out most empty substrings as candidates for
* replacement. When they are detected, no replacement is done, and the
* result is the original string.
*/
if ((last < 0) || /* Range ends before start of string */
(first > end) || /* Range begins after end of string */
(last < first)) { /* Range begins after it starts */
/*
* BUT!!! when (end < 0) -- an empty original string -- we can
* have (first <= end < 0 <= last) and an empty string is permitted
* to be replaced.
*/
|
| ︙ | ︙ | |||
2523 2524 2525 2526 2527 2528 2529 |
int delta = 0;
const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
| | < > | 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 |
int delta = 0;
const Tcl_UniChar *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
next = p > string ? p - 1 : p;
do {
next += delta;
delta = 1;
ch = *next;
} while (next + delta < p);
p = next;
}
if (cur != index) {
cur += 1;
}
}
|
| ︙ | ︙ | |||
2645 2646 2647 2648 2649 2650 2651 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
| | | 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length);
if ((length > 1) && !strncmp(string2, "-nocase", length)) {
nocase = 1;
} else if ((length > 1)
&& !strncmp(string2, "-length", length)) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
|
| ︙ | ︙ | |||
2748 2749 2750 2751 2752 2753 2754 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
| | | 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 |
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
string = Tcl_GetStringFromObj(objv[i], &length);
if ((length > 1) && !strncmp(string, "-nocase", length)) {
*nocase = 1;
} else if ((length > 1)
&& !strncmp(string, "-length", length)) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
|
| ︙ | ︙ | |||
2889 2890 2891 2892 2893 2894 2895 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | | | 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 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToLower(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp, objv[2], length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToLower(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | | | 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 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp, objv[2], length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToUpper(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
3059 3060 3061 3062 3063 3064 3065 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
| | | | | 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 |
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
Tcl_Size first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp, objv[2], length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
resultPtr = Tcl_NewStringObj(string1, end - string1);
string2 = TclGetString(resultPtr) + (start - string1);
length2 = Tcl_UtfToTitle(string2);
Tcl_SetObjLength(resultPtr, length2 + (start - string1));
|
| ︙ | ︙ | |||
3139 3140 3141 3142 3143 3144 3145 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
Tcl_Size triml, trimr, length1, length2;
if (objc == 3) {
| | | | 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 |
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
Tcl_Size triml, trimr, length1, length2;
if (objc == 3) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
triml = TclTrim(string1, length1, string2, length2, &trimr);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3187 3188 3189 3190 3191 3192 3193 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
| | | | 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
trim = TclTrimLeft(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3234 3235 3236 3237 3238 3239 3240 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
| | | | 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 |
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
string2 = Tcl_GetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
}
string1 = Tcl_GetStringFromObj(objv[1], &length1);
trim = TclTrimRight(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
return TCL_OK;
}
|
| ︙ | ︙ | |||
3659 3660 3661 3662 3663 3664 3665 |
}
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
| | | 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 |
}
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
pattern = Tcl_GetStringFromObj(objv[i], &patternLength);
if ((i == objc - 2) && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
Tcl_Obj *emptyObj = NULL;
/*
* If either indexVarObj or matchVarObj are non-NULL, we're in
|
| ︙ | ︙ | |||
3698 3699 3700 3701 3702 3703 3704 |
switch (mode) {
case OPT_EXACT:
if (strCmpFn(TclGetString(stringObj), pattern) == 0) {
goto matchFound;
}
break;
case OPT_GLOB:
| | | 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 |
switch (mode) {
case OPT_EXACT:
if (strCmpFn(TclGetString(stringObj), pattern) == 0) {
goto matchFound;
}
break;
case OPT_GLOB:
if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, noCase)) {
goto matchFound;
}
break;
case OPT_REGEXP:
regExpr = Tcl_GetRegExpFromObj(interp, objv[i],
TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0));
if (regExpr == NULL) {
|
| ︙ | ︙ | |||
5300 5301 5302 5303 5304 5305 5306 |
TclListLines(
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
* structure. Assumed to be valid. Assumed to
* contain n elements. */
Tcl_Size line, /* Line the list as a whole starts on. */
Tcl_Size n, /* #elements in lines */
Tcl_Size *lines, /* Array of line numbers, to fill. */
| | | 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 |
TclListLines(
Tcl_Obj *listObj, /* Pointer to obj holding a string with list
* structure. Assumed to be valid. Assumed to
* contain n elements. */
Tcl_Size line, /* Line the list as a whole starts on. */
Tcl_Size n, /* #elements in lines */
Tcl_Size *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
const char *listStr = TclGetString(listObj);
const char *listHead = listStr;
Tcl_Size i, length = strlen(listStr);
const char *element = NULL, *next = NULL;
ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various Tcl
* commands into a sequence of instructions ("bytecodes").
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
| > | | > | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)
Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->varLists[0] = (ForeachVarList *)
Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 | Tcl_Obj **objs; const char *bytes; Tcl_Size len, slen; TclListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); | | | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
Tcl_Obj **objs;
const char *bytes;
Tcl_Size len, slen;
TclListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
bytes = Tcl_GetStringFromObj(objPtr, &slen);
PushLiteral(envPtr, bytes, slen);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
/*
* General case: runtime concat.
|
| ︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 |
Tcl_Size numBytes;
int code;
Tcl_Token *incrTokenPtr;
Tcl_Obj *intObj;
incrTokenPtr = TokenAfter(keyTokenPtr);
if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
| | | | 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 |
Tcl_Size numBytes;
int code;
Tcl_Token *incrTokenPtr;
Tcl_Obj *intObj;
incrTokenPtr = TokenAfter(keyTokenPtr);
if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
word = incrTokenPtr[1].start;
numBytes = incrTokenPtr[1].size;
intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
code = TclGetIntFromObj(NULL, intObj, &incrAmount);
TclDecrRefCount(intObj);
if (code != TCL_OK) {
return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
} else {
incrAmount = 1;
}
/*
* The dictionary variable must be a local scalar that is knowable at
|
| ︙ | ︙ | |||
1404 1405 1406 1407 1408 1409 1410 |
Tcl_DecrRefCount(valueObj);
}
/*
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
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;
/*
|
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
/*
* Get the index of the local variable that we will be working with.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
| | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
/*
* Get the index of the local variable that we will be working with.
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Produce the string to concatenate onto the dictionary entry.
*/
tokenPtr = TokenAfter(tokenPtr);
|
| ︙ | ︙ | |||
2844 2845 2846 2847 2848 2849 2850 |
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
int varIndex;
Tcl_Size length;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
| | | 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 |
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
int varIndex;
Tcl_Size length;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = Tcl_GetStringFromObj(varNameObj, &length);
varIndex = LocalScalar(bytes, length, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
varListPtr->varIndexes[j] = varIndex;
}
|
| ︙ | ︙ | |||
2960 2961 2962 2963 2964 2965 2966 | * the new ForeachInfo record. * *---------------------------------------------------------------------- */ static void * DupForeachInfo( | | | 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 |
* the new ForeachInfo record.
*
*----------------------------------------------------------------------
*/
static void *
DupForeachInfo(
void *clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
|
| ︙ | ︙ | |||
3009 3010 3011 3012 3013 3014 3015 | * ForeachInfo structure. * *---------------------------------------------------------------------- */ static void FreeForeachInfo( | | | 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 |
* ForeachInfo structure.
*
*----------------------------------------------------------------------
*/
static void
FreeForeachInfo(
void *clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
size_t i, numLists = infoPtr->numLists;
for (i = 0; i < numLists; i++) {
|
| ︙ | ︙ | |||
3279 3280 3281 3282 3283 3284 3285 |
}
/*
* Not an error, always a constant result, so just push the result as a
* literal. Job done.
*/
| | | 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 |
}
/*
* 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
|
| ︙ | ︙ | |||
3342 3343 3344 3345 3346 3347 3348 |
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
start = TclGetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
| | | | 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 |
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
start = TclGetString(formatObj);
/* The start of the currently-scanned literal
* in the format string. */
TclNewObj(tmpObj); /* 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 {
const char *b = Tcl_GetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
* push it and reset.
*/
if (len > 0) {
|
| ︙ | ︙ | |||
3384 3385 3386 3387 3388 3389 3390 |
}
/*
* Handle the case of a trailing literal.
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
| | | 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 |
}
/*
* 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);
|
| ︙ | ︙ | |||
3592 3593 3594 3595 3596 3597 3598 |
name = varTokenPtr[1].start;
nameLen = p - varTokenPtr[1].start;
elName = p + 1;
remainingLen = (varTokenPtr[2].start - p) - 1;
elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
if (!(flags & TCL_NO_ELEMENT)) {
| | | | | | | > | | | | | | | | | | | | | | | | | | | 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 |
name = varTokenPtr[1].start;
nameLen = p - varTokenPtr[1].start;
elName = p + 1;
remainingLen = (varTokenPtr[2].start - p) - 1;
elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
elemTokenPtr = (Tcl_Token *)
TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
/*
* Copy the remaining tokens.
*/
memcpy(elemTokenPtr + 1, varTokenPtr + 2,
(n-1) * sizeof(Tcl_Token));
} else {
/*
* Use the already available tokens.
*/
elemTokenPtr = &varTokenPtr[2];
elemTokenCount = n - 1;
}
}
}
}
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclCompCmdsGR.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 'g' through 'r') into a sequence
* of instructions ("bytecodes").
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * When TCL_OK is returned, the encoded index value is written | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
* compile time.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
*
* Side effects:
* When TCL_OK is returned, the encoded index value is written
* to *indexPtr.
*
*----------------------------------------------------------------------
*/
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
haveImmValue = 1;
}
/*
* Emit the instruction to increment the variable.
*/
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
haveImmValue = 1;
}
/*
* Emit the instruction to increment the variable.
*/
if (isScalar) { /* Simple scalar variable. */
if (localIndex >= 0) {
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
TclEmitInt1(immValue, envPtr);
} else {
TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
}
|
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
/* Push list, first, last onto the stack */
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
| > > > > > > > | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 |
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* For now, disable compilation of lreplace. Figure out later if any
* compilation can be done given that any Tcl_ObjType may implement
* lreplace, and should return an object of the same type.
*/
return TCL_ERROR;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
/* Push list, first, last onto the stack */
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 |
* Attempt to convert pattern to glob. If successful, push the
* converted pattern as a literal.
*/
if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL)
== TCL_OK) {
simple = 1;
| | | 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
* Attempt to convert pattern to glob. If successful, push the
* converted pattern as a literal.
*/
if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL)
== TCL_OK) {
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
}
if (!simple) {
CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2);
}
|
| ︙ | ︙ | |||
2169 2170 2171 2172 2173 2174 2175 |
}
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
*/
| | | 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 |
}
/*
* 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, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
}
bytes = Tcl_DStringValue(&pattern);
if (*bytes++ != '*') {
goto done;
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
goto done;
}
bytes++;
}
isSimpleGlob:
for (bytes = TclGetString(replacementObj); *bytes; bytes++) {
switch (*bytes) {
| | > | | 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 |
goto done;
}
bytes++;
}
isSimpleGlob:
for (bytes = TclGetString(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, (int)parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
Tcl_DStringFree(&pattern);
if (patternObj) {
|
| ︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
Tcl_Size numBytes;
| | | 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
Tcl_Size numBytes;
const char *bytes = Tcl_GetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
}
|
| ︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 |
if (lastTokenPtr->type != TCL_TOKEN_TEXT) {
Tcl_DecrRefCount(tailPtr);
return -1;
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
| | | 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 |
if (lastTokenPtr->type != TCL_TOKEN_TEXT) {
Tcl_DecrRefCount(tailPtr);
return -1;
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
tailName = Tcl_GetStringFromObj(tailPtr, &len);
if (len) {
if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
*/
|
| ︙ | ︙ |
1 | /* | < < < < < < < > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1997-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
* Copyright © 2002 ActiveState Corporation.
* Copyright © 2004-2010 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclCompCmdsSZ.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 's' through 'z', except for
* [upvar] and [variable]) into a sequence of instructions ("bytecodes").
* Also includes the operator command compilers.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclStringTrim.h"
/*
* Prototypes for procedures defined later in this file:
*/
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
Tcl_Size len;
| | | | 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 |
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
Tcl_Size len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
CompileWord(envPtr, wordTokenPtr, interp, i);
numArgs ++;
if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
numArgs = 1; /* concat pushes 1 obj, the result */
}
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
if (folded) {
Tcl_Size len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
if (numArgs > 1) {
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 |
/*
* 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.
*/
| | | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
/*
* 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], &slen);
if (slen == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, slen);
bytes = Tcl_GetStringFromObj(objv[1], &slen);
PushLiteral(envPtr, bytes, slen);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 |
OP( POP); /* Pop newString */
}
/* Original string argument now on TOS as result */
return TCL_OK;
}
if (parsePtr->numWords == 5) {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > < | | < < < < < < < < | 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 |
OP( POP); /* Pop newString */
}
/* Original string argument now on TOS as result */
return TCL_OK;
}
if (parsePtr->numWords == 5) {
/*
* When we have a string replacement, we have to take care about
* not replacing empty substrings that [string replace] promises
* not to replace
*
* The remaining index values might be suitable for conventional
* string replacement, but only if they cannot possibly meet the
* conditions described above at runtime. If there's a chance they
* might, we would have to emit bytecode to check and at that point
* we're paying more in bytecode execution time than would make
* things worthwhile. Trouble is we are very limited in
* how much we can detect that at compile time. After decoding,
* we need, first:
*
* (first <= end)
*
* The encoded indices (first <= TCL_INDEX END) and
* (first == TCL_INDEX_NONE) always meets this condition, but
* any other encoded first index has some list for which it fails.
*
* We also need, second:
*
* (last >= 0)
*
* The encoded index (last >= TCL_INDEX_START) always meet this
* condition but any other encoded last index has some list for
* which it fails.
*
* Finally we need, third:
*
* (first <= last)
*
* Considered in combination with the constraints we already have,
* we see that we can proceed when (first == TCL_INDEX_NONE).
* These also permit simplification of the prefix|replace|suffix
* construction. The other constraints, though, interfere with
* getting a guarantee that first <= last.
*/
if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) {
/* empty prefix */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP4( REVERSE, 2);
if (last == INT_MAX) {
OP( POP); /* Pop original */
} else {
OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
}
return TCL_OK;
}
if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) {
OP44( STR_RANGE_IMM, 0, first-1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
/* FLOW THROUGH TO genericReplace */
} else {
/*
* When we have no replacement string to worry about, we may
* have more luck, because the forbidden empty string replacements
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 |
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
objc++;
goto cleanup;
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
| < > < > | 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 |
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
objc++;
goto cleanup;
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
#if 0
if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) {
toSubst = objv[numOpts];
Tcl_IncrRefCount(toSubst);
}
#endif
/* TODO: Figure out expansion to cover WordKnownAtCompileTime
* The difficulty is that WKACT makes a copy, and if TclSubstParse
* below parses the copy of the original source string, some deep
* parts of the compile machinery get upset. They want all pointers
* stored in Tcl_Tokens to point back to the same original string.
*/
|
| ︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 |
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
Tcl_Size numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
| | | > | 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 |
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
Tcl_Size numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
Tcl_Size *bodyLines, /* Array of line numbers for body list
* items. */
Tcl_Size **bodyContLines) /* Array of continuation line info. */
{
enum {Switch_Exact, Switch_Glob, Switch_Regexp};
int foundDefault; /* Flag to indicate whether a "default" clause
* is present. */
JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
unsigned int *fixupTargetArray;
/* Array of places for fixups to point at. */
int fixupCount; /* Number of places to fix up. */
int contFixIndex; /* Where the first of the jumps due to a group
* of continuation bodies starts, or -1 if
* there aren't any. */
int contFixCount; /* Number of continuation bodies pointing to
* the current (or next) real body. */
int nextArmFixupIndex;
|
| ︙ | ︙ | |||
2359 2360 2361 2362 2363 2364 2365 |
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
| | | 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 |
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
Tcl_Size *bodyLines, /* Array of line numbers for body list
* items. */
Tcl_Size **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
|
| ︙ | ︙ | |||
2912 2913 2914 2915 2916 2917 2918 |
if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
Tcl_Size len;
| | | | 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 |
if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
Tcl_Size len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
resultVarIndices[i] = -1;
}
if (objc == 2) {
Tcl_Size len;
const char *varname = Tcl_GetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
|
| ︙ | ︙ | |||
3131 3132 3133 3134 3135 3136 3137 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
|
| ︙ | ︙ | |||
3671 3672 3673 3674 3675 3676 3677 |
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
Tcl_Size len;
| | | 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 |
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
Tcl_Size len;
bytes = Tcl_GetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
} else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
haveFlags++;
} else {
varCount++;
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclCompExpr.c -- * * This file contains the code to parse and compile Tcl expressions and * implementations of the Tcl commands corresponding to expression * operators, such as the command ::tcl::mathop::+ . | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclCompExpr.c -- * * This file contains the code to parse and compile Tcl expressions and * implementations of the Tcl commands corresponding to expression * operators, such as the command ::tcl::mathop::+ . */ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ /* * Expression parsing takes place in the routine ParseExpr(). It takes a |
| ︙ | ︙ | |||
742 743 744 745 746 747 748 | * When we compile the expression we'll need the function * name, and there's no place in the parse tree to store * it, so we keep a separate list of all the function * names we've parsed in the order we found them. */ Tcl_ListObjAppendElement(NULL, funcList, literal); | | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
* When we compile the expression we'll need the function
* name, and there's no place in the parse tree to store
* it, so we keep a separate list of all the function
* names we've parsed in the order we found them.
*/
Tcl_ListObjAppendElement(NULL, funcList, literal);
} else if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) {
lexeme = BOOLEAN;
} else {
/*
* Tricky case: see test expr-62.10
*/
int scanned2 = scanned;
|
| ︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 |
* first null character. */
Tcl_Parse *parsePtr) /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is ignored. */
{
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
| | | | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
* first null character. */
Tcl_Parse *parsePtr) /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is ignored. */
{
int code;
OpNode *opTree = NULL; /* Will point to the tree of operators. */
Tcl_Obj *litList; /* List to hold the literals. */
Tcl_Obj *funcList; /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
TclNewObj(litList);
TclNewObj(funcList);
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 | /* * We have a number followed directly by bareword characters * (alpha, digit, underscore). Is this a number followed by * bareword syntax error? Or should we join into one bareword? * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ | | | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 |
/*
* We have a number followed directly by bareword characters
* (alpha, digit, underscore). Is this a number followed by
* bareword syntax error? Or should we join into one bareword?
* Example: Inf + luence + () becomes a valid function call.
* [Bug 3401704]
*/
if (TclHasInternalRep(literal, tclDoubleTypePtr)) {
const char *p = start;
while (p < end) {
if (!TclIsBareword(*p++)) {
/*
* The number has non-bareword characters, so we
* must treat it as a number.
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
Tcl_Size length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
| | | 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 |
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
Tcl_Size length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = Tcl_GetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
Tcl_DStringFree(&cmdName);
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 |
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
Tcl_Size length;
| | | 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 |
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
Tcl_Size length;
const char *bytes = Tcl_GetStringFromObj(literal, &length);
int idx = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
/*
* Would like to do this:
*
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
* already, then use it to share via the literal table.
*/
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
Tcl_Size numBytes;
const char *bytes
| | | 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 |
* already, then use it to share via the literal table.
*/
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
Tcl_Size numBytes;
const char *bytes
= Tcl_GetStringFromObj(objPtr, &numBytes);
idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
* Same internalrep surgery as for OT_LITERAL.
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1996-1998 Sun Microsystems, Inc.
* Copyright © 2001 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts of
* commands (like quoted strings or nested sub-commands) into a sequence
* of instructions ("bytecodes").
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <assert.h>
/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
const Tcl_ObjType tclByteCodeType = {
"bytecode", /* name */
FreeByteCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetByteCodeFromAny, /* setFromAnyProc */
| < > < > | 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 |
const Tcl_ObjType tclByteCodeType = {
"bytecode", /* name */
FreeByteCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetByteCodeFromAny, /* setFromAnyProc */
0
};
/*
* substCodeType provides the standard type management procedures for the
* substcode type, which represents substitution within a Tcl value.
*/
static const Tcl_ObjType substCodeType = {
"substcode", /* name */
FreeSubstCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2
/*
* Helper macros.
*/
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
int
TclSetByteCodeFromAny(
Tcl_Interp *interp, /* The interpreter for which the code is being
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
| | | | 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 |
int
TclSetByteCodeFromAny(
Tcl_Interp *interp, /* The interpreter for which the code is being
* compiled. Must not be NULL. */
Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
void *clientData) /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
Tcl_Size length;
int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
&tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
stringPtr = Tcl_GetStringFromObj(objPtr, &length);
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 | * delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
* delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
ByteCode *codePtr;
ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 |
/* Just dropped to refcount==0. Clean up. */
CleanupByteCode(codePtr);
}
static void
CleanupByteCode(
| | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
/* Just dropped to refcount==0. Clean up. */
CleanupByteCode(codePtr);
}
static void
CleanupByteCode(
ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
Interp *iPtr = (Interp *) interp;
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
Tcl_Obj **objArrayPtr, *objPtr;
const AuxData *auxDataPtr;
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
Tcl_Size numBytes;
| | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 |
Tcl_StoreInternalRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
Tcl_Size numBytes;
const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
TclEmitOpcode(INST_DONE, &compEnv);
|
| ︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 | * the cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeSubstCodeInternalRep( | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 |
* the cleanup is delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeSubstCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
ByteCode *codePtr;
ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
|
| ︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 |
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
| | | 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 |
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
CompileEnv *envPtr, /* Points to the CompileEnv structure to
* initialize. */
const char *stringPtr, /* The source string to be compiled. */
size_t numBytes, /* Number of bytes in source string. */
const CmdFrame *invoker, /* Location context invoking the bcc */
int word) /* Index of the word in that context getting
* compiled */
{
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
Tcl_Size length;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
| | | 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 |
Tcl_Size length;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = Tcl_GetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
|
| ︙ | ︙ | |||
2635 2636 2637 2638 2639 2640 2641 |
*/
void
TclCompileCmdWord(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
* a command word to compile inline. */
| | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
*/
void
TclCompileCmdWord(
Tcl_Interp *interp, /* Used for error and status reporting. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
* a command word to compile inline. */
size_t count1, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
int count = count1;
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
/*
|
| ︙ | ︙ | |||
2817 2818 2819 2820 2821 2822 2823 | * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we * can be sure we do not have any lingering cycles hiding in * the internalrep. */ Tcl_Size numBytes; | | | 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 | * * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we * can be sure we do not have any lingering cycles hiding in * the internalrep. */ Tcl_Size numBytes; const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(copyPtr); TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); envPtr->literalArrayPtr[i].objPtr = copyPtr; } |
| ︙ | ︙ | |||
3020 3021 3022 3023 3024 3025 3026 | * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ Tcl_Size TclFindCompiledLocal( | | | 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
* variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclFindCompiledLocal(
const char *name, /* Points to first character of the name of a
* scalar or array variable. If NULL, a
* temporary var should be created. */
Tcl_Size nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
CompileEnv *envPtr) /* Points to the current compile environment*/
{
|
| ︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 |
if (!cachePtr || !name) {
return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
| | | | 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 |
if (!cachePtr || !name) {
return TCL_INDEX_NONE;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
localName = Tcl_GetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
return TCL_INDEX_NONE;
}
if (name != NULL) {
Tcl_Size localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((nameBytes == localPtr->nameLength) &&
(strncmp(name, localName, nameBytes) == 0)) {
return i;
}
}
localPtr = localPtr->nextPtr;
}
}
|
| ︙ | ︙ | |||
3199 3200 3201 3202 3203 3204 3205 |
EnterCmdStartData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
Tcl_Size cmdIndex, /* Index of the command whose start data is
* being set. */
Tcl_Size srcOffset, /* Offset of first char of the command. */
| | | 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 |
EnterCmdStartData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
Tcl_Size cmdIndex, /* Index of the command whose start data is
* being set. */
Tcl_Size srcOffset, /* Offset of first char of the command. */
Tcl_Size codeOffset) /* Offset of first byte of command code. */
{
CmdLocation *cmdLocPtr;
if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) {
Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
}
|
| ︙ | ︙ | |||
3277 3278 3279 3280 3281 3282 3283 |
static void
EnterCmdExtentData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
Tcl_Size cmdIndex, /* Index of the command whose source and code
* length data is being set. */
| | | | 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 |
static void
EnterCmdExtentData(
CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
Tcl_Size cmdIndex, /* Index of the command whose source and code
* length data is being set. */
Tcl_Size numSrcBytes, /* Number of command source chars. */
Tcl_Size numCodeBytes) /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) {
Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex);
}
|
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 | * If there is not enough room in the CompileEnv's AuxData array, its size * is doubled. *---------------------------------------------------------------------- */ Tcl_Size TclCreateAuxData( | | | < | | 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 |
* If there is not enough room in the CompileEnv's AuxData array, its size
* is doubled.
*----------------------------------------------------------------------
*/
Tcl_Size
TclCreateAuxData(
void *clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
CompileEnv *envPtr) /* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
Tcl_Size index; /* Index for the new AuxData structure. */
AuxData *auxDataPtr; /* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
/*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
|
| ︙ | ︙ |
1 | /* | < < > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclCompile.h -- * */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #include "tclInt.h" struct ByteCode; /* Forward declaration. */ |
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
* duplicate objects. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated code
* array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded and
* codeStart points into the heap.*/
| < < < < < < < < < < | 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 |
* duplicate objects. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated code
* array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded and
* codeStart points into the heap.*/
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
LiteralEntry *literalArrayPtr;
/* Points to start of LiteralEntry array. */
Tcl_Size literalArrayNext; /* Index of next free object array entry. */
Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */
int mallocedLiteralArray; /* 1 if object array was expanded and objArray
* points into the heap, else 0. */
ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index.
* exceptArrayNext is the number of ranges and
* (exceptArrayNext-1) is the index of the
* current range's array entry. */
Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array
* entry. */
ExceptionAux *exceptAuxArrayPtr;
/* Array of information used to restore the
* state when processing BREAK/CONTINUE
* exceptions. Must be the same size as the
* exceptArrayPtr. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
* for the last command. */
Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */
int mallocedCmdMap; /* 1 if command map array was expanded and
* cmdMapPtr points in the heap, else 0. */
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */
Tcl_Size auxDataArrayNext; /* Next free compile aux data array index.
* auxDataArrayNext is the number of aux data
* items and (auxDataArrayNext-1) is index of
* current aux data array entry. */
Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
/* Initial storage for code. */
LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
* are used for indexes or for, e.g., the count of objects to push in a "push"
* instruction.
*/
#define MAX_INSTRUCTION_OPERANDS 2
typedef enum InstOperandType {
| | | 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
* are used for indexes or for, e.g., the count of objects to push in a "push"
* instruction.
*/
#define MAX_INSTRUCTION_OPERANDS 2
typedef enum InstOperandType {
OPERAND_NONE, /* No operand. */
OPERAND_INT1, /* One byte signed integer. */
OPERAND_INT4, /* Four byte signed integer. */
OPERAND_UINT1, /* One byte unsigned integer. */
OPERAND_UINT4, /* Four byte unsigned integer. */
OPERAND_IDX4, /* Four byte signed index (actually an
* integer, but displayed differently.) */
OPERAND_LVT1, /* One byte unsigned index into the local
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ | < | 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 | /* *---------------------------------------------------------------- * 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 *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 | Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 | Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 |
tclDTraceDebugLog = fopen(n, "a"); \
}
#define TclDTraceDbgMsg(p, m, ...) \
do { \
if (tclDTraceDebugEnabled) { \
int _l, _t = 0; \
| | > > | | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 |
tclDTraceDebugLog = fopen(n, "a"); \
}
#define TclDTraceDbgMsg(p, m, ...) \
do { \
if (tclDTraceDebugEnabled) { \
int _l, _t = 0; \
if (!tclDTraceDebugLog) { \
TclDTraceOpenDebugLog(); \
} \
fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \
strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \
fprintf(tclDTraceDebugLog, " %.*s():%n", \
(_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \
fprintf(tclDTraceDebugLog, "%*s" p "%n", \
(_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \
"", &_l); _t += _l; \
fprintf(tclDTraceDebugLog, "%*s" m "\n", \
(_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \
fflush(tclDTraceDebugLog); \
} \
} while (0)
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclConfig.c -- * * This file provides the facilities which allow Tcl and other packages * to embed configuration information into their binary libraries. */ #include "tclInt.h" /* * Internal structure to hold embedded configuration information. * * Our structure is a two-level dictionary associated with the 'interp'. The * first level is keyed with the package name and maps to the dictionary for |
| ︙ | ︙ | |||
387 388 389 390 391 392 393 | * The package metadata database is freed. * *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc( | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
* The package metadata database is freed.
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
void *clientData, /* Pointer to Tcl_Obj. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 | /* | < < < < > > > > | > > > > > > > > > > > | 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 |
/*
* Copyright (c) 2007-2008 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.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclDTrace.d --
*
* Tcl DTrace provider.
*/
typedef struct Tcl_Obj Tcl_Obj;
typedef ptrdiff_t Tcl_Size;
/*
* Tcl DTrace probes
*/
provider tcl {
/***************************** proc probes *****************************/
|
| ︙ | ︙ |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | # define YYLTYPE_IS_DECLARED 1 # define YYLTYPE_IS_TRIVIAL 1 #endif | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
# define YYLTYPE_IS_DECLARED 1
# define YYLTYPE_IS_TRIVIAL 1
#endif
static int TclDateparse (DateInfo* info);
/* Symbol kind. */
enum yysymbol_kind_t
{
YYSYMBOL_YYEMPTY = -2,
|
| ︙ | ︙ |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 |
/* A Bison parser, made by GNU Bison 3.8.2. */
/* Bison implementation for Yacc-like parsers in C
Copyright (C) 1984, 1989-1990, 2000-2015, 2018-2021 Free Software Foundation,
Inc.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
under terms of your choice, so long as that work isn't itself a
parser generator using the skeleton or a modified version thereof
as a parser skeleton. Alternatively, if you modify or redistribute
the parser skeleton itself, you may (at your option) remove this
special exception, which will cause the skeleton and the resulting
Bison output files to be licensed under the GNU General Public
License without this special exception.
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
/* C LALR(1) parser skeleton written by Richard Stallman, by
simplifying the original so-called "semantic" parser. */
/* DO NOT RELY ON FEATURES THAT ARE NOT DOCUMENTED in the manual,
especially those whose name start with YY_ or yy_. They are
private implementation details that can be changed or removed. */
/* All symbols defined below should begin with yy or YY, to avoid
infringing on user name space. This should be done even for local
variables, as they might otherwise be expanded by user macros.
There are some unavoidable exceptions within include files to
define necessary library symbols; they are noted "INFRINGES ON
USER NAME SPACE" below. */
/* Identify Bison output, and Bison version. */
#define YYBISON 30802
/* Bison version string. */
#define YYBISON_VERSION "3.8.2"
/* Skeleton name. */
#define YYSKELETON_NAME "yacc.c"
/* Pure parsers. */
#define YYPURE 1
/* Push parsers. */
#define YYPUSH 0
/* Pull parsers. */
#define YYPULL 1
/* Substitute the variable and function names. */
#define yyparse TclDateparse
#define yylex TclDatelex
#define yyerror TclDateerror
#define yydebug TclDatedebug
/* First part of user prologue. */
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
* Copyright (c) 1992-1995 Karl Lehenbauer & Mark Diekhans.
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
*/
#include "tclInt.h"
/*
* Bison generates several labels that happen to be unused. MS Visual C++
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
MERIDIAN dateMeridian;
int dateHaveTime;
time_t dateTimezone;
int dateDSTmode;
int dateHaveZone;
time_t dateRelMonth;
time_t dateRelDay;
time_t dateRelSeconds;
int dateHaveRel;
time_t dateMonthOrdinal;
int dateHaveOrdinalMonth;
time_t dateDayOrdinal;
time_t dateDayNumber;
int dateHaveDay;
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth)
#define yyHaveRel (info->dateHaveRel)
#define yyHaveTime (info->dateHaveTime)
#define yyHaveZone (info->dateHaveZone)
#define yyTimezone (info->dateTimezone)
#define yyDay (info->dateDay)
#define yyMonth (info->dateMonth)
#define yyYear (info->dateYear)
#define yyHour (info->dateHour)
#define yyMinutes (info->dateMinutes)
#define yySeconds (info->dateSeconds)
#define yyMeridian (info->dateMeridian)
#define yyRelMonth (info->dateRelMonth)
#define yyRelDay (info->dateRelDay)
#define yyRelSeconds (info->dateRelSeconds)
#define yyRelPointer (info->dateRelPointer)
#define yyInput (info->dateInput)
#define yyDigitCount (info->dateDigitCount)
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((int) (60 * (x)))
#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
/*
* An entry in the lexical lookup table.
*/
typedef struct _TABLE {
const char *name;
int type;
time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_CAST
# ifdef __cplusplus
# define YY_CAST(Type, Val) static_cast<Type> (Val)
# define YY_REINTERPRET_CAST(Type, Val) reinterpret_cast<Type> (Val)
# else
# define YY_CAST(Type, Val) ((Type) (Val))
# define YY_REINTERPRET_CAST(Type, Val) ((Type) (Val))
# endif
# endif
# ifndef YY_NULLPTR
# if defined __cplusplus
# if 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
# else
# define YY_NULLPTR ((void*)0)
# endif
# endif
/* Debug traces. */
#ifndef YYDEBUG
# define YYDEBUG 0
#endif
#if YYDEBUG
extern int TclDatedebug;
#endif
/* Token kinds. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
enum yytokentype
{
YYEMPTY = -2,
YYEOF = 0, /* "end of file" */
YYerror = 256, /* error */
YYUNDEF = 257, /* "invalid token" */
tAGO = 258, /* tAGO */
tDAY = 259, /* tDAY */
tDAYZONE = 260, /* tDAYZONE */
tID = 261, /* tID */
tMERIDIAN = 262, /* tMERIDIAN */
tMONTH = 263, /* tMONTH */
tMONTH_UNIT = 264, /* tMONTH_UNIT */
tSTARDATE = 265, /* tSTARDATE */
tSEC_UNIT = 266, /* tSEC_UNIT */
tSNUMBER = 267, /* tSNUMBER */
tUNUMBER = 268, /* tUNUMBER */
tZONE = 269, /* tZONE */
tEPOCH = 270, /* tEPOCH */
tDST = 271, /* tDST */
tISOBASE = 272, /* tISOBASE */
tDAY_UNIT = 273, /* tDAY_UNIT */
tNEXT = 274 /* tNEXT */
};
typedef enum yytokentype yytoken_kind_t;
#endif
/* Value type. */
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
union YYSTYPE
{
time_t Number;
enum _MERIDIAN Meridian;
};
typedef union YYSTYPE YYSTYPE;
# define YYSTYPE_IS_TRIVIAL 1
# define YYSTYPE_IS_DECLARED 1
#endif
/* Location type. */
#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
typedef struct YYLTYPE YYLTYPE;
struct YYLTYPE
{
int first_line;
int first_column;
int last_line;
int last_column;
};
# define YYLTYPE_IS_DECLARED 1
# define YYLTYPE_IS_TRIVIAL 1
#endif
int TclDateparse (DateInfo* info);
/* Symbol kind. */
enum yysymbol_kind_t
{
YYSYMBOL_YYEMPTY = -2,
YYSYMBOL_YYEOF = 0, /* "end of file" */
YYSYMBOL_YYerror = 1, /* error */
YYSYMBOL_YYUNDEF = 2, /* "invalid token" */
YYSYMBOL_tAGO = 3, /* tAGO */
YYSYMBOL_tDAY = 4, /* tDAY */
YYSYMBOL_tDAYZONE = 5, /* tDAYZONE */
YYSYMBOL_tID = 6, /* tID */
YYSYMBOL_tMERIDIAN = 7, /* tMERIDIAN */
YYSYMBOL_tMONTH = 8, /* tMONTH */
YYSYMBOL_tMONTH_UNIT = 9, /* tMONTH_UNIT */
YYSYMBOL_tSTARDATE = 10, /* tSTARDATE */
YYSYMBOL_tSEC_UNIT = 11, /* tSEC_UNIT */
YYSYMBOL_tSNUMBER = 12, /* tSNUMBER */
YYSYMBOL_tUNUMBER = 13, /* tUNUMBER */
YYSYMBOL_tZONE = 14, /* tZONE */
YYSYMBOL_tEPOCH = 15, /* tEPOCH */
YYSYMBOL_tDST = 16, /* tDST */
YYSYMBOL_tISOBASE = 17, /* tISOBASE */
YYSYMBOL_tDAY_UNIT = 18, /* tDAY_UNIT */
YYSYMBOL_tNEXT = 19, /* tNEXT */
YYSYMBOL_20_ = 20, /* ':' */
YYSYMBOL_21_ = 21, /* ',' */
YYSYMBOL_22_ = 22, /* '/' */
YYSYMBOL_23_ = 23, /* '-' */
YYSYMBOL_24_ = 24, /* '.' */
YYSYMBOL_25_ = 25, /* '+' */
YYSYMBOL_YYACCEPT = 26, /* $accept */
YYSYMBOL_spec = 27, /* spec */
YYSYMBOL_item = 28, /* item */
YYSYMBOL_time = 29, /* time */
YYSYMBOL_zone = 30, /* zone */
YYSYMBOL_day = 31, /* day */
YYSYMBOL_date = 32, /* date */
YYSYMBOL_ordMonth = 33, /* ordMonth */
YYSYMBOL_iso = 34, /* iso */
YYSYMBOL_trek = 35, /* trek */
YYSYMBOL_relspec = 36, /* relspec */
YYSYMBOL_relunits = 37, /* relunits */
YYSYMBOL_sign = 38, /* sign */
YYSYMBOL_unit = 39, /* unit */
YYSYMBOL_number = 40, /* number */
YYSYMBOL_o_merid = 41 /* o_merid */
};
typedef enum yysymbol_kind_t yysymbol_kind_t;
/* Second part of user prologue. */
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
DateInfo* info);
static time_t ToSeconds(time_t Hours, time_t Minutes,
time_t Seconds, MERIDIAN Meridian);
MODULE_SCOPE int yyparse(DateInfo*);
#ifdef short
# undef short
#endif
/* On compilers that do not define __PTRDIFF_MAX__ etc., make sure
<limits.h> and (if available) <stdint.h> are included
so that the code can choose integer types of a good width. */
#ifndef __PTRDIFF_MAX__
# include <limits.h> /* INFRINGES ON USER NAME SPACE */
# if defined __STDC_VERSION__ && 199901 <= __STDC_VERSION__
# include <stdint.h> /* INFRINGES ON USER NAME SPACE */
# define YY_STDINT_H
# endif
#endif
/* Narrow types that promote to a signed type and that can represent a
signed or unsigned integer of at least N bits. In tables they can
save space and decrease cache pressure. Promoting to a signed type
helps avoid bugs in integer arithmetic. */
#ifdef __INT_LEAST8_MAX__
typedef __INT_LEAST8_TYPE__ yytype_int8;
#elif defined YY_STDINT_H
typedef int_least8_t yytype_int8;
#else
typedef signed char yytype_int8;
#endif
#ifdef __INT_LEAST16_MAX__
typedef __INT_LEAST16_TYPE__ yytype_int16;
#elif defined YY_STDINT_H
typedef int_least16_t yytype_int16;
#else
typedef short yytype_int16;
#endif
/* Work around bug in HP-UX 11.23, which defines these macros
incorrectly for preprocessor constants. This workaround can likely
be removed in 2023, as HPE has promised support for HP-UX 11.23
(aka HP-UX 11i v2) only through the end of 2022; see Table 2 of
<https://h20195.www2.hpe.com/V2/getpdf.aspx/4AA4-7673ENW.pdf>. */
#ifdef __hpux
# undef UINT_LEAST8_MAX
# undef UINT_LEAST16_MAX
# define UINT_LEAST8_MAX 255
# define UINT_LEAST16_MAX 65535
#endif
#if defined __UINT_LEAST8_MAX__ && __UINT_LEAST8_MAX__ <= __INT_MAX__
typedef __UINT_LEAST8_TYPE__ yytype_uint8;
#elif (!defined __UINT_LEAST8_MAX__ && defined YY_STDINT_H \
&& UINT_LEAST8_MAX <= INT_MAX)
typedef uint_least8_t yytype_uint8;
#elif !defined __UINT_LEAST8_MAX__ && UCHAR_MAX <= INT_MAX
typedef unsigned char yytype_uint8;
#else
typedef short yytype_uint8;
#endif
#if defined __UINT_LEAST16_MAX__ && __UINT_LEAST16_MAX__ <= __INT_MAX__
typedef __UINT_LEAST16_TYPE__ yytype_uint16;
#elif (!defined __UINT_LEAST16_MAX__ && defined YY_STDINT_H \
&& UINT_LEAST16_MAX <= INT_MAX)
typedef uint_least16_t yytype_uint16;
#elif !defined __UINT_LEAST16_MAX__ && USHRT_MAX <= INT_MAX
typedef unsigned short yytype_uint16;
#else
typedef int yytype_uint16;
#endif
#ifndef YYPTRDIFF_T
# if defined __PTRDIFF_TYPE__ && defined __PTRDIFF_MAX__
# define YYPTRDIFF_T __PTRDIFF_TYPE__
# define YYPTRDIFF_MAXIMUM __PTRDIFF_MAX__
# elif defined PTRDIFF_MAX
# ifndef ptrdiff_t
# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# endif
# define YYPTRDIFF_T ptrdiff_t
# define YYPTRDIFF_MAXIMUM PTRDIFF_MAX
# else
# define YYPTRDIFF_T long
# define YYPTRDIFF_MAXIMUM LONG_MAX
# endif
#endif
#ifndef YYSIZE_T
# ifdef __SIZE_TYPE__
# define YYSIZE_T __SIZE_TYPE__
# elif defined size_t
# define YYSIZE_T size_t
# elif defined __STDC_VERSION__ && 199901 <= __STDC_VERSION__
# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
# define YYSIZE_T size_t
# else
# define YYSIZE_T unsigned
# endif
#endif
#define YYSIZE_MAXIMUM \
YY_CAST (YYPTRDIFF_T, \
(YYPTRDIFF_MAXIMUM < YY_CAST (YYSIZE_T, -1) \
? YYPTRDIFF_MAXIMUM \
: YY_CAST (YYSIZE_T, -1)))
#define YYSIZEOF(X) YY_CAST (YYPTRDIFF_T, sizeof (X))
/* Stored state numbers (used for stacks). */
typedef yytype_int8 yy_state_t;
/* State numbers in computations. */
typedef int yy_state_fast_t;
#ifndef YY_
# if defined YYENABLE_NLS && YYENABLE_NLS
# if ENABLE_NLS
# include <libintl.h> /* INFRINGES ON USER NAME SPACE */
# define YY_(Msgid) dgettext ("bison-runtime", Msgid)
# endif
# endif
# ifndef YY_
# define YY_(Msgid) Msgid
# endif
#endif
#ifndef YY_ATTRIBUTE_PURE
# if defined __GNUC__ && 2 < __GNUC__ + (96 <= __GNUC_MINOR__)
# define YY_ATTRIBUTE_PURE __attribute__ ((__pure__))
# else
# define YY_ATTRIBUTE_PURE
# endif
#endif
#ifndef YY_ATTRIBUTE_UNUSED
# if defined __GNUC__ && 2 < __GNUC__ + (7 <= __GNUC_MINOR__)
# define YY_ATTRIBUTE_UNUSED __attribute__ ((__unused__))
# else
# define YY_ATTRIBUTE_UNUSED
# endif
#endif
/* Suppress unused-variable warnings by "using" E. */
#if ! defined lint || defined __GNUC__
# define YY_USE(E) ((void) (E))
#else
# define YY_USE(E) /* empty */
#endif
/* Suppress an incorrect diagnostic about yylval being uninitialized. */
#if defined __GNUC__ && ! defined __ICC && 406 <= __GNUC__ * 100 + __GNUC_MINOR__
# if __GNUC__ * 100 + __GNUC_MINOR__ < 407
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")
# else
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuninitialized\"") \
_Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"")
# endif
# define YY_IGNORE_MAYBE_UNINITIALIZED_END \
_Pragma ("GCC diagnostic pop")
#else
# define YY_INITIAL_VALUE(Value) Value
#endif
#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
# define YY_IGNORE_MAYBE_UNINITIALIZED_END
#endif
#ifndef YY_INITIAL_VALUE
# define YY_INITIAL_VALUE(Value) /* Nothing. */
#endif
#if defined __cplusplus && defined __GNUC__ && ! defined __ICC && 6 <= __GNUC__
# define YY_IGNORE_USELESS_CAST_BEGIN \
_Pragma ("GCC diagnostic push") \
_Pragma ("GCC diagnostic ignored \"-Wuseless-cast\"")
# define YY_IGNORE_USELESS_CAST_END \
_Pragma ("GCC diagnostic pop")
#endif
#ifndef YY_IGNORE_USELESS_CAST_BEGIN
# define YY_IGNORE_USELESS_CAST_BEGIN
# define YY_IGNORE_USELESS_CAST_END
#endif
#define YY_ASSERT(E) ((void) (0 && (E)))
#if !defined yyoverflow
/* The parser invokes alloca or malloc; define the necessary symbols. */
# ifdef YYSTACK_USE_ALLOCA
# if YYSTACK_USE_ALLOCA
# ifdef __GNUC__
# define YYSTACK_ALLOC __builtin_alloca
# elif defined __BUILTIN_VA_ARG_INCR
# include <alloca.h> /* INFRINGES ON USER NAME SPACE */
# elif defined _AIX
# define YYSTACK_ALLOC __alloca
# elif defined _MSC_VER
# include <malloc.h> /* INFRINGES ON USER NAME SPACE */
# define alloca _alloca
# else
# define YYSTACK_ALLOC alloca
# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
/* Use EXIT_SUCCESS as a witness for stdlib.h. */
# ifndef EXIT_SUCCESS
# define EXIT_SUCCESS 0
# endif
# endif
# endif
# endif
# endif
# ifdef YYSTACK_ALLOC
/* Pacify GCC's 'empty if-body' warning. */
# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
# ifndef YYSTACK_ALLOC_MAXIMUM
/* The OS might guarantee only one guard page at the bottom of the stack,
and a page size can be as small as 4096 bytes. So we cannot safely
invoke alloca (N) if N exceeds 4096. Use a slightly smaller number
to allow for a few compiler-allocated temporary stack slots. */
# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */
# endif
# else
# define YYSTACK_ALLOC YYMALLOC
# define YYSTACK_FREE YYFREE
# ifndef YYSTACK_ALLOC_MAXIMUM
# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM
# endif
# if (defined __cplusplus && ! defined EXIT_SUCCESS \
&& ! ((defined YYMALLOC || defined malloc) \
&& (defined YYFREE || defined free)))
# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
# ifndef EXIT_SUCCESS
# define EXIT_SUCCESS 0
# endif
# endif
# ifndef YYMALLOC
# define YYMALLOC malloc
# if ! defined malloc && ! defined EXIT_SUCCESS
void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# ifndef YYFREE
# define YYFREE free
# if ! defined free && ! defined EXIT_SUCCESS
void free (void *); /* INFRINGES ON USER NAME SPACE */
# endif
# endif
# endif
#endif /* !defined yyoverflow */
#if (! defined yyoverflow \
&& (! defined __cplusplus \
|| (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \
&& defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL)))
/* A type that is properly aligned for any stack member. */
union yyalloc
{
yy_state_t yyss_alloc;
YYSTYPE yyvs_alloc;
YYLTYPE yyls_alloc;
};
/* The size of the maximum gap between one aligned stack and the next. */
# define YYSTACK_GAP_MAXIMUM (YYSIZEOF (union yyalloc) - 1)
/* The size of an array large to enough to hold all stacks, each with
N elements. */
# define YYSTACK_BYTES(N) \
((N) * (YYSIZEOF (yy_state_t) + YYSIZEOF (YYSTYPE) \
+ YYSIZEOF (YYLTYPE)) \
+ 2 * YYSTACK_GAP_MAXIMUM)
# define YYCOPY_NEEDED 1
/* Relocate STACK from its old location to the new one. The
local variables YYSIZE and YYSTACKSIZE give the old and new number of
elements in the stack, and YYPTR gives the new location of the
stack. Advance YYPTR to a properly aligned location for the next
stack. */
# define YYSTACK_RELOCATE(Stack_alloc, Stack) \
do \
{ \
YYPTRDIFF_T yynewbytes; \
YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \
Stack = &yyptr->Stack_alloc; \
yynewbytes = yystacksize * YYSIZEOF (*Stack) + YYSTACK_GAP_MAXIMUM; \
yyptr += yynewbytes / YYSIZEOF (*yyptr); \
} \
while (0)
#endif
#if defined YYCOPY_NEEDED && YYCOPY_NEEDED
/* Copy COUNT objects from SRC to DST. The source and destination do
not overlap. */
# ifndef YYCOPY
# if defined __GNUC__ && 1 < __GNUC__
# define YYCOPY(Dst, Src, Count) \
__builtin_memcpy (Dst, Src, YY_CAST (YYSIZE_T, (Count)) * sizeof (*(Src)))
# else
# define YYCOPY(Dst, Src, Count) \
do \
{ \
YYPTRDIFF_T yyi; \
for (yyi = 0; yyi < (Count); yyi++) \
(Dst)[yyi] = (Src)[yyi]; \
} \
while (0)
# endif
# endif
#endif /* !YYCOPY_NEEDED */
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
#define YYLAST 81
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 26
/* YYNNTS -- Number of nonterminals. */
#define YYNNTS 16
/* YYNRULES -- Number of rules. */
#define YYNRULES 56
/* YYNSTATES -- Number of states. */
#define YYNSTATES 85
/* YYMAXUTOK -- Last valid token kind. */
#define YYMAXUTOK 274
/* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, with out-of-bounds checking. */
#define YYTRANSLATE(YYX) \
(0 <= (YYX) && (YYX) <= YYMAXUTOK \
? YY_CAST (yysymbol_kind_t, yytranslate[YYX]) \
: YYSYMBOL_YYUNDEF)
/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM
as returned by yylex. */
static const yytype_int8 yytranslate[] =
{
0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 25, 21, 23, 24, 22, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 20, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 1, 2, 3, 4,
5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_int16 yyrline[] =
{
0, 223, 223, 224, 227, 230, 233, 236, 239, 242,
245, 249, 254, 257, 263, 269, 277, 282, 287, 291,
297, 301, 305, 309, 313, 319, 323, 328, 333, 338,
343, 347, 352, 356, 361, 368, 372, 378, 388, 397,
406, 416, 430, 435, 438, 441, 444, 447, 450, 455,
458, 463, 467, 471, 477, 495, 498
};
#endif
/** Accessing symbol of state STATE. */
#define YY_ACCESSING_SYMBOL(State) YY_CAST (yysymbol_kind_t, yystos[State])
#if YYDEBUG || 0
/* The user-facing name of the symbol whose (internal) number is
YYSYMBOL. No bounds checking. */
static const char *yysymbol_name (yysymbol_kind_t yysymbol) YY_ATTRIBUTE_UNUSED;
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
{
"\"end of file\"", "error", "\"invalid token\"", "tAGO", "tDAY",
"tDAYZONE", "tID", "tMERIDIAN", "tMONTH", "tMONTH_UNIT", "tSTARDATE",
"tSEC_UNIT", "tSNUMBER", "tUNUMBER", "tZONE", "tEPOCH", "tDST",
"tISOBASE", "tDAY_UNIT", "tNEXT", "':'", "','", "'/'", "'-'", "'.'",
"'+'", "$accept", "spec", "item", "time", "zone", "day", "date",
"ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit",
"number", "o_merid", YY_NULLPTR
};
static const char *
yysymbol_name (yysymbol_kind_t yysymbol)
{
return yytname[yysymbol];
}
#endif
#define YYPACT_NINF (-18)
#define yypact_value_is_default(Yyn) \
((Yyn) == YYPACT_NINF)
#define YYTABLE_NINF (-1)
#define yytable_value_is_error(Yyn) \
0
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
static const yytype_int8 yypact[] =
{
-18, 2, -18, -17, -18, -4, -18, 10, -18, 22,
8, -18, 18, -18, 39, -18, -18, -18, -18, -18,
-18, -18, -18, -18, -18, -18, 25, 21, -18, -18,
-18, 16, 14, -18, -18, 28, 36, 41, -5, -18,
-18, 5, -18, -18, -18, 47, -18, -18, 42, 46,
48, -18, -6, 40, 43, 44, 49, -18, -18, -18,
-18, -18, -18, -18, -18, 50, -18, 51, 55, 57,
58, 65, -18, -18, 59, 54, -18, 62, 63, 60,
-18, 64, 61, 66, -18
};
/* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM.
Performed when YYTABLE does not specify something else to do. Zero
means the default is an error. */
static const yytype_int8 yydefact[] =
{
2, 0, 1, 20, 18, 0, 53, 0, 51, 54,
17, 33, 27, 52, 0, 49, 50, 3, 4, 5,
8, 6, 7, 10, 11, 9, 43, 0, 48, 12,
21, 30, 0, 22, 13, 32, 0, 0, 0, 45,
16, 0, 40, 24, 35, 0, 46, 42, 19, 0,
0, 34, 55, 25, 0, 0, 0, 38, 36, 47,
23, 44, 31, 41, 56, 0, 14, 0, 0, 0,
0, 55, 26, 28, 29, 0, 15, 0, 0, 0,
39, 0, 0, 0, 37
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int8 yypgoto[] =
{
-18, -18, -18, -18, -18, -18, -18, -18, -18, -18,
-18, -18, -18, -9, -18, 7
};
/* YYDEFGOTO[NTERM-NUM]. */
static const yytype_int8 yydefgoto[] =
{
0, 1, 17, 18, 19, 20, 21, 22, 23, 24,
25, 26, 27, 28, 29, 66
};
/* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule whose
number is the opposite. If YYTABLE_NINF, syntax error. */
static const yytype_int8 yytable[] =
{
39, 64, 2, 54, 30, 46, 3, 4, 55, 31,
5, 6, 7, 8, 65, 9, 10, 11, 56, 12,
13, 14, 57, 32, 40, 15, 33, 16, 47, 34,
35, 6, 41, 8, 48, 42, 59, 49, 50, 61,
13, 51, 36, 43, 37, 38, 60, 44, 6, 52,
8, 6, 45, 8, 53, 58, 6, 13, 8, 62,
13, 63, 67, 71, 72, 13, 68, 69, 73, 70,
74, 75, 64, 77, 78, 79, 80, 82, 76, 84,
81, 83
};
static const yytype_int8 yycheck[] =
{
9, 7, 0, 8, 21, 14, 4, 5, 13, 13,
8, 9, 10, 11, 20, 13, 14, 15, 13, 17,
18, 19, 17, 13, 16, 23, 4, 25, 3, 7,
8, 9, 14, 11, 13, 17, 45, 21, 24, 48,
18, 13, 20, 4, 22, 23, 4, 8, 9, 13,
11, 9, 13, 11, 13, 8, 9, 18, 11, 13,
18, 13, 22, 13, 13, 18, 23, 23, 13, 20,
13, 13, 7, 14, 20, 13, 13, 13, 71, 13,
20, 20
};
/* YYSTOS[STATE-NUM] -- The symbol kind of the accessing symbol of
state STATE-NUM. */
static const yytype_int8 yystos[] =
{
0, 27, 0, 4, 5, 8, 9, 10, 11, 13,
14, 15, 17, 18, 19, 23, 25, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
21, 13, 13, 4, 7, 8, 20, 22, 23, 39,
16, 14, 17, 4, 8, 13, 39, 3, 13, 21,
24, 13, 13, 13, 8, 13, 13, 17, 8, 39,
4, 39, 13, 13, 7, 20, 41, 22, 23, 23,
20, 13, 13, 13, 13, 13, 41, 14, 20, 13,
13, 20, 13, 20, 13
};
/* YYR1[RULE-NUM] -- Symbol kind of the left-hand side of rule RULE-NUM. */
static const yytype_int8 yyr1[] =
{
0, 26, 27, 27, 28, 28, 28, 28, 28, 28,
28, 28, 28, 29, 29, 29, 30, 30, 30, 30,
31, 31, 31, 31, 31, 32, 32, 32, 32, 32,
32, 32, 32, 32, 32, 33, 33, 34, 34, 34,
34, 35, 36, 36, 37, 37, 37, 37, 37, 38,
38, 39, 39, 39, 40, 41, 41
};
/* YYR2[RULE-NUM] -- Number of symbols on the right-hand side of rule RULE-NUM. */
static const yytype_int8 yyr2[] =
{
0, 2, 0, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1, 2, 4, 6, 2, 1, 1, 2,
1, 2, 2, 3, 2, 3, 5, 1, 5, 5,
2, 4, 2, 1, 3, 2, 3, 11, 3, 7,
2, 4, 2, 1, 3, 2, 2, 3, 1, 1,
1, 1, 1, 1, 1, 0, 1
};
enum { YYENOMEM = -2 };
#define yyerrok (yyerrstatus = 0)
#define yyclearin (yychar = YYEMPTY)
#define YYACCEPT goto yyacceptlab
#define YYABORT goto yyabortlab
#define YYERROR goto yyerrorlab
#define YYNOMEM goto yyexhaustedlab
#define YYRECOVERING() (!!yyerrstatus)
#define YYBACKUP(Token, Value) \
do \
if (yychar == YYEMPTY) \
{ \
yychar = (Token); \
yylval = (Value); \
YYPOPSTACK (yylen); \
yystate = *yyssp; \
goto yybackup; \
} \
else \
{ \
yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \
YYERROR; \
} \
while (0)
/* Backward compatibility with an undocumented macro.
Use YYerror or YYUNDEF. */
#define YYERRCODE YYUNDEF
/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
If N is 0, then set CURRENT to the empty location which ends
the previous symbol: RHS[0] (always defined). */
#ifndef YYLLOC_DEFAULT
# define YYLLOC_DEFAULT(Current, Rhs, N) \
do \
if (N) \
{ \
(Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
(Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
(Current).last_line = YYRHSLOC (Rhs, N).last_line; \
(Current).last_column = YYRHSLOC (Rhs, N).last_column; \
} \
else \
{ \
(Current).first_line = (Current).last_line = \
YYRHSLOC (Rhs, 0).last_line; \
(Current).first_column = (Current).last_column = \
YYRHSLOC (Rhs, 0).last_column; \
} \
while (0)
#endif
#define YYRHSLOC(Rhs, K) ((Rhs)[K])
/* Enable debugging if requested. */
#if YYDEBUG
# ifndef YYFPRINTF
# include <stdio.h> /* INFRINGES ON USER NAME SPACE */
# define YYFPRINTF fprintf
# endif
# define YYDPRINTF(Args) \
do { \
if (yydebug) \
YYFPRINTF Args; \
} while (0)
/* YYLOCATION_PRINT -- Print the location on the stream.
This macro was not mandated originally: define only if we know
we won't break user code: when these are the locations we know. */
# ifndef YYLOCATION_PRINT
# if defined YY_LOCATION_PRINT
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YYLOCATION_PRINT(File, Loc) YY_LOCATION_PRINT(File, *(Loc))
# elif defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
/* Print *YYLOCP on YYO. Private, do not rely on its existence. */
YY_ATTRIBUTE_UNUSED
static int
yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp)
{
int res = 0;
int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0;
if (0 <= yylocp->first_line)
{
res += YYFPRINTF (yyo, "%d", yylocp->first_line);
if (0 <= yylocp->first_column)
res += YYFPRINTF (yyo, ".%d", yylocp->first_column);
}
if (0 <= yylocp->last_line)
{
if (yylocp->first_line < yylocp->last_line)
{
res += YYFPRINTF (yyo, "-%d", yylocp->last_line);
if (0 <= end_col)
res += YYFPRINTF (yyo, ".%d", end_col);
}
else if (0 <= end_col && yylocp->first_column < end_col)
res += YYFPRINTF (yyo, "-%d", end_col);
}
return res;
}
# define YYLOCATION_PRINT yy_location_print_
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YY_LOCATION_PRINT(File, Loc) YYLOCATION_PRINT(File, &(Loc))
# else
# define YYLOCATION_PRINT(File, Loc) ((void) 0)
/* Temporary convenience wrapper in case some people defined the
undocumented and private YY_LOCATION_PRINT macros. */
# define YY_LOCATION_PRINT YYLOCATION_PRINT
# endif
# endif /* !defined YYLOCATION_PRINT */
# define YY_SYMBOL_PRINT(Title, Kind, Value, Location) \
do { \
if (yydebug) \
{ \
YYFPRINTF (stderr, "%s ", Title); \
yy_symbol_print (stderr, \
Kind, Value, Location, info); \
YYFPRINTF (stderr, "\n"); \
} \
} while (0)
/*-----------------------------------.
| Print this symbol's value on YYO. |
`-----------------------------------*/
static void
yy_symbol_value_print (FILE *yyo,
yysymbol_kind_t yykind, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
FILE *yyoutput = yyo;
YY_USE (yyoutput);
YY_USE (yylocationp);
YY_USE (info);
if (!yyvaluep)
return;
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
YY_USE (yykind);
YY_IGNORE_MAYBE_UNINITIALIZED_END
}
/*---------------------------.
| Print this symbol on YYO. |
`---------------------------*/
static void
yy_symbol_print (FILE *yyo,
yysymbol_kind_t yykind, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info)
{
YYFPRINTF (yyo, "%s %s (",
yykind < YYNTOKENS ? "token" : "nterm", yysymbol_name (yykind));
YYLOCATION_PRINT (yyo, yylocationp);
YYFPRINTF (yyo, ": ");
yy_symbol_value_print (yyo, yykind, yyvaluep, yylocationp, info);
YYFPRINTF (yyo, ")");
}
/*------------------------------------------------------------------.
| yy_stack_print -- Print the state stack from its BOTTOM up to its |
| TOP (included). |
`------------------------------------------------------------------*/
static void
yy_stack_print (yy_state_t *yybottom, yy_state_t *yytop)
{
YYFPRINTF (stderr, "Stack now");
for (; yybottom <= yytop; yybottom++)
{
int yybot = *yybottom;
YYFPRINTF (stderr, " %d", yybot);
}
YYFPRINTF (stderr, "\n");
}
# define YY_STACK_PRINT(Bottom, Top) \
do { \
if (yydebug) \
yy_stack_print ((Bottom), (Top)); \
} while (0)
/*------------------------------------------------.
| Report that the YYRULE is going to be reduced. |
`------------------------------------------------*/
static void
yy_reduce_print (yy_state_t *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp,
int yyrule, DateInfo* info)
{
int yylno = yyrline[yyrule];
int yynrhs = yyr2[yyrule];
int yyi;
YYFPRINTF (stderr, "Reducing stack by rule %d (line %d):\n",
yyrule - 1, yylno);
/* The symbols being reduced. */
for (yyi = 0; yyi < yynrhs; yyi++)
{
YYFPRINTF (stderr, " $%d = ", yyi + 1);
yy_symbol_print (stderr,
YY_ACCESSING_SYMBOL (+yyssp[yyi + 1 - yynrhs]),
&yyvsp[(yyi + 1) - (yynrhs)],
&(yylsp[(yyi + 1) - (yynrhs)]), info);
YYFPRINTF (stderr, "\n");
}
}
# define YY_REDUCE_PRINT(Rule) \
do { \
if (yydebug) \
yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \
} while (0)
/* Nonzero means print parse trace. It is left uninitialized so that
multiple parsers can coexist. */
int yydebug;
#else /* !YYDEBUG */
# define YYDPRINTF(Args) ((void) 0)
# define YY_SYMBOL_PRINT(Title, Kind, Value, Location)
# define YY_STACK_PRINT(Bottom, Top)
# define YY_REDUCE_PRINT(Rule)
#endif /* !YYDEBUG */
/* YYINITDEPTH -- initial size of the parser's stacks. */
#ifndef YYINITDEPTH
# define YYINITDEPTH 200
#endif
/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
if the built-in stack extension method is used).
Do not make this value too large; the results are undefined if
YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH)
evaluated with infinite-precision integer arithmetic. */
#ifndef YYMAXDEPTH
# define YYMAXDEPTH 10000
#endif
/*-----------------------------------------------.
| Release the memory associated to this symbol. |
`-----------------------------------------------*/
static void
yydestruct (const char *yymsg,
yysymbol_kind_t yykind, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info)
{
YY_USE (yyvaluep);
YY_USE (yylocationp);
YY_USE (info);
if (!yymsg)
yymsg = "Deleting";
YY_SYMBOL_PRINT (yymsg, yykind, yyvaluep, yylocationp);
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
YY_USE (yykind);
YY_IGNORE_MAYBE_UNINITIALIZED_END
}
/*----------.
| yyparse. |
`----------*/
int
yyparse (DateInfo* info)
{
/* Lookahead token kind. */
int yychar;
/* The semantic value of the lookahead symbol. */
/* Default value used for initialization, for pacifying older GCCs
or non-GCC compilers. */
YY_INITIAL_VALUE (static YYSTYPE yyval_default;)
YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default);
/* Location data for the lookahead symbol. */
static YYLTYPE yyloc_default
# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL
= { 1, 1, 1, 1 }
# endif
;
YYLTYPE yylloc = yyloc_default;
yy_state_fast_t yystate = 0;
/* Number of tokens to shift before error messages enabled. */
int yyerrstatus = 0;
/* Refer to the stacks through separate pointers, to allow yyoverflow
to reallocate them elsewhere. */
/* Their size. */
YYPTRDIFF_T yystacksize = YYINITDEPTH;
/* The state stack: array, bottom, top. */
yy_state_t yyssa[YYINITDEPTH];
yy_state_t *yyss = yyssa;
yy_state_t *yyssp = yyss;
/* The semantic value stack: array, bottom, top. */
YYSTYPE yyvsa[YYINITDEPTH];
YYSTYPE *yyvs = yyvsa;
YYSTYPE *yyvsp = yyvs;
/* The location stack: array, bottom, top. */
YYLTYPE yylsa[YYINITDEPTH];
YYLTYPE *yyls = yylsa;
YYLTYPE *yylsp = yyls;
int yyn;
/* The return value of yyparse. */
int yyresult;
/* Lookahead symbol kind. */
yysymbol_kind_t yytoken = YYSYMBOL_YYEMPTY;
/* The variables used to return semantic value and location from the
action routines. */
YYSTYPE yyval;
YYLTYPE yyloc;
/* The locations where the error started and ended. */
YYLTYPE yyerror_range[3];
#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N))
/* The number of symbols on the RHS of the reduced rule.
Keep to zero when no symbol should be popped. */
int yylen = 0;
YYDPRINTF ((stderr, "Starting parse\n"));
yychar = YYEMPTY; /* Cause a token to be read. */
yylsp[0] = yylloc;
goto yysetstate;
/*------------------------------------------------------------.
| yynewstate -- push a new state, which is found in yystate. |
`------------------------------------------------------------*/
yynewstate:
/* In all cases, when you get here, the value and location stacks
have just been pushed. So pushing a state here evens the stacks. */
yyssp++;
/*--------------------------------------------------------------------.
| yysetstate -- set current state (the top of the stack) to yystate. |
`--------------------------------------------------------------------*/
yysetstate:
YYDPRINTF ((stderr, "Entering state %d\n", yystate));
YY_ASSERT (0 <= yystate && yystate < YYNSTATES);
YY_IGNORE_USELESS_CAST_BEGIN
*yyssp = YY_CAST (yy_state_t, yystate);
YY_IGNORE_USELESS_CAST_END
YY_STACK_PRINT (yyss, yyssp);
if (yyss + yystacksize - 1 <= yyssp)
#if !defined yyoverflow && !defined YYSTACK_RELOCATE
YYNOMEM;
#else
{
/* Get the current used size of the three stacks, in elements. */
YYPTRDIFF_T yysize = yyssp - yyss + 1;
# if defined yyoverflow
{
/* Give user a chance to reallocate the stack. Use copies of
these so that the &'s don't force the real ones into
memory. */
yy_state_t *yyss1 = yyss;
YYSTYPE *yyvs1 = yyvs;
YYLTYPE *yyls1 = yyls;
/* Each stack pointer address is followed by the size of the
data in use in that stack, in bytes. This used to be a
conditional around just the two extra args, but that might
be undefined if yyoverflow is a macro. */
yyoverflow (YY_("memory exhausted"),
&yyss1, yysize * YYSIZEOF (*yyssp),
&yyvs1, yysize * YYSIZEOF (*yyvsp),
&yyls1, yysize * YYSIZEOF (*yylsp),
&yystacksize);
yyss = yyss1;
yyvs = yyvs1;
yyls = yyls1;
}
# else /* defined YYSTACK_RELOCATE */
/* Extend the stack our own way. */
if (YYMAXDEPTH <= yystacksize)
YYNOMEM;
yystacksize *= 2;
if (YYMAXDEPTH < yystacksize)
yystacksize = YYMAXDEPTH;
{
yy_state_t *yyss1 = yyss;
union yyalloc *yyptr =
YY_CAST (union yyalloc *,
YYSTACK_ALLOC (YY_CAST (YYSIZE_T, YYSTACK_BYTES (yystacksize))));
if (! yyptr)
YYNOMEM;
YYSTACK_RELOCATE (yyss_alloc, yyss);
YYSTACK_RELOCATE (yyvs_alloc, yyvs);
YYSTACK_RELOCATE (yyls_alloc, yyls);
# undef YYSTACK_RELOCATE
if (yyss1 != yyssa)
YYSTACK_FREE (yyss1);
}
# endif
yyssp = yyss + yysize - 1;
yyvsp = yyvs + yysize - 1;
yylsp = yyls + yysize - 1;
YY_IGNORE_USELESS_CAST_BEGIN
YYDPRINTF ((stderr, "Stack size increased to %ld\n",
YY_CAST (long, yystacksize)));
YY_IGNORE_USELESS_CAST_END
if (yyss + yystacksize - 1 <= yyssp)
YYABORT;
}
#endif /* !defined yyoverflow && !defined YYSTACK_RELOCATE */
if (yystate == YYFINAL)
YYACCEPT;
goto yybackup;
/*-----------.
| yybackup. |
`-----------*/
yybackup:
/* Do appropriate processing given the current state. Read a
lookahead token if we need one and don't already have one. */
/* First try to decide what to do without reference to lookahead token. */
yyn = yypact[yystate];
if (yypact_value_is_default (yyn))
goto yydefault;
/* Not known => get a lookahead token if don't already have one. */
/* YYCHAR is either empty, or end-of-input, or a valid lookahead. */
if (yychar == YYEMPTY)
{
YYDPRINTF ((stderr, "Reading a token\n"));
yychar = yylex (&yylval, &yylloc, info);
}
if (yychar <= YYEOF)
{
yychar = YYEOF;
yytoken = YYSYMBOL_YYEOF;
YYDPRINTF ((stderr, "Now at end of input.\n"));
}
else if (yychar == YYerror)
{
/* The scanner already issued an error message, process directly
to error recovery. But do not keep the error token as
lookahead, it is too special and may lead us to an endless
loop in error recovery. */
yychar = YYUNDEF;
yytoken = YYSYMBOL_YYerror;
yyerror_range[1] = yylloc;
goto yyerrlab1;
}
else
{
yytoken = YYTRANSLATE (yychar);
YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc);
}
/* If the proper action on seeing token YYTOKEN is to reduce or to
detect an error, take that action. */
yyn += yytoken;
if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
goto yydefault;
yyn = yytable[yyn];
if (yyn <= 0)
{
if (yytable_value_is_error (yyn))
goto yyerrlab;
yyn = -yyn;
goto yyreduce;
}
/* Count tokens shifted since error; after three, turn off error
status. */
if (yyerrstatus)
yyerrstatus--;
/* Shift the lookahead token. */
YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
yystate = yyn;
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
*++yylsp = yylloc;
/* Discard the shifted token. */
yychar = YYEMPTY;
goto yynewstate;
/*-----------------------------------------------------------.
| yydefault -- do the default action for the current state. |
`-----------------------------------------------------------*/
yydefault:
yyn = yydefact[yystate];
if (yyn == 0)
goto yyerrlab;
goto yyreduce;
/*-----------------------------.
| yyreduce -- do a reduction. |
`-----------------------------*/
yyreduce:
/* yyn is the number of a rule to reduce with. */
yylen = yyr2[yyn];
/* If YYLEN is nonzero, implement the default value of the action:
'$$ = $1'.
Otherwise, the following line sets YYVAL to garbage.
This behavior is undocumented and Bison
users should not rely upon it. Assigning to YYVAL
unconditionally makes the parser a bit smaller, and it avoids a
GCC warning that YYVAL may be used uninitialized. */
yyval = yyvsp[1-yylen];
/* Default location. */
YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
yyerror_range[1] = yyloc;
YY_REDUCE_PRINT (yyn);
switch (yyn)
{
case 4: /* item: time */
{
yyHaveTime++;
}
break;
case 5: /* item: zone */
{
yyHaveZone++;
}
break;
case 6: /* item: date */
{
yyHaveDate++;
}
break;
case 7: /* item: ordMonth */
{
yyHaveOrdinalMonth++;
}
break;
case 8: /* item: day */
{
yyHaveDay++;
}
break;
case 9: /* item: relspec */
{
yyHaveRel++;
}
break;
case 10: /* item: iso */
{
yyHaveTime++;
yyHaveDate++;
}
break;
case 11: /* item: trek */
{
yyHaveTime++;
yyHaveDate++;
yyHaveRel++;
}
break;
case 13: /* time: tUNUMBER tMERIDIAN */
{
yyHour = (yyvsp[-1].Number);
yyMinutes = 0;
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 14: /* time: tUNUMBER ':' tUNUMBER o_merid */
{
yyHour = (yyvsp[-3].Number);
yyMinutes = (yyvsp[-1].Number);
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 15: /* time: tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid */
{
yyHour = (yyvsp[-5].Number);
yyMinutes = (yyvsp[-3].Number);
yySeconds = (yyvsp[-1].Number);
yyMeridian = (yyvsp[0].Meridian);
}
break;
case 16: /* zone: tZONE tDST */
{
yyTimezone = (yyvsp[-1].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
break;
case 17: /* zone: tZONE */
{
yyTimezone = (yyvsp[0].Number);
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
break;
case 18: /* zone: tDAYZONE */
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
case 19: /* zone: sign tUNUMBER */
{
yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
case 20: /* day: tDAY */
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 21: /* day: tDAY ',' */
{
yyDayOrdinal = 1;
yyDayNumber = (yyvsp[-1].Number);
}
break;
case 22: /* day: tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 23: /* day: sign tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
yyDayNumber = (yyvsp[0].Number);
}
break;
case 24: /* day: tNEXT tDAY */
{
yyDayOrdinal = 2;
yyDayNumber = (yyvsp[0].Number);
}
break;
case 25: /* date: tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 26: /* date: tUNUMBER '/' tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 27: /* date: tISOBASE */
{
yyYear = (yyvsp[0].Number) / 10000;
yyMonth = ((yyvsp[0].Number) % 10000)/100;
yyDay = (yyvsp[0].Number) % 100;
}
break;
case 28: /* date: tUNUMBER '-' tMONTH '-' tUNUMBER */
{
yyDay = (yyvsp[-4].Number);
yyMonth = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 29: /* date: tUNUMBER '-' tUNUMBER '-' tUNUMBER */
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
yyYear = (yyvsp[-4].Number);
}
break;
case 30: /* date: tMONTH tUNUMBER */
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[0].Number);
}
break;
case 31: /* date: tMONTH tUNUMBER ',' tUNUMBER */
{
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 32: /* date: tUNUMBER tMONTH */
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
case 33: /* date: tEPOCH */
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
case 34: /* date: tUNUMBER tMONTH tUNUMBER */
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
case 35: /* ordMonth: tNEXT tMONTH */
{
yyMonthOrdinal = 1;
yyMonth = (yyvsp[0].Number);
}
break;
case 36: /* ordMonth: tNEXT tUNUMBER tMONTH */
{
yyMonthOrdinal = (yyvsp[-1].Number);
yyMonth = (yyvsp[0].Number);
}
break;
case 37: /* iso: tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER */
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-10].Number);
yyMonth = (yyvsp[-8].Number);
yyDay = (yyvsp[-6].Number);
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
break;
case 38: /* iso: tISOBASE tZONE tISOBASE */
{
if ((yyvsp[-1].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-2].Number) / 10000;
yyMonth = ((yyvsp[-2].Number) % 10000)/100;
yyDay = (yyvsp[-2].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 39: /* iso: tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER */
{
if ((yyvsp[-5].Number) != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = (yyvsp[-6].Number) / 10000;
yyMonth = ((yyvsp[-6].Number) % 10000)/100;
yyDay = (yyvsp[-6].Number) % 100;
yyHour = (yyvsp[-4].Number);
yyMinutes = (yyvsp[-2].Number);
yySeconds = (yyvsp[0].Number);
}
break;
case 40: /* iso: tISOBASE tISOBASE */
{
yyYear = (yyvsp[-1].Number) / 10000;
yyMonth = ((yyvsp[-1].Number) % 10000)/100;
yyDay = (yyvsp[-1].Number) % 100;
yyHour = (yyvsp[0].Number) / 10000;
yyMinutes = ((yyvsp[0].Number) % 10000)/100;
yySeconds = (yyvsp[0].Number) % 100;
}
break;
case 41: /* trek: tSTARDATE tUNUMBER '.' tUNUMBER */
{
/*
* Offset computed year by -377 so that the returned years will be
* in a range accessible with a 32 bit clock seconds value.
*/
yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += (yyvsp[0].Number) * 144 * 60;
}
break;
case 42: /* relspec: relunits tAGO */
{
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
break;
case 44: /* relunits: sign tUNUMBER unit */
{
*yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 45: /* relunits: tUNUMBER unit */
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 46: /* relunits: tNEXT unit */
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 47: /* relunits: tNEXT tUNUMBER unit */
{
*yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
}
break;
case 48: /* relunits: unit */
{
*yyRelPointer += (yyvsp[0].Number);
}
break;
case 49: /* sign: '-' */
{
(yyval.Number) = -1;
}
break;
case 50: /* sign: '+' */
{
(yyval.Number) = 1;
}
break;
case 51: /* unit: tSEC_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelSeconds;
}
break;
case 52: /* unit: tDAY_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelDay;
}
break;
case 53: /* unit: tMONTH_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelMonth;
}
break;
case 54: /* number: tUNUMBER */
{
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = (yyvsp[0].Number);
} else {
yyHaveTime++;
if (yyDigitCount <= 2) {
yyHour = (yyvsp[0].Number);
yyMinutes = 0;
} else {
yyHour = (yyvsp[0].Number) / 100;
yyMinutes = (yyvsp[0].Number) % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
}
break;
case 55: /* o_merid: %empty */
{
(yyval.Meridian) = MER24;
}
break;
case 56: /* o_merid: tMERIDIAN */
{
(yyval.Meridian) = (yyvsp[0].Meridian);
}
break;
default: break;
}
/* User semantic actions sometimes alter yychar, and that requires
that yytoken be updated with the new translation. We take the
approach of translating immediately before every use of yytoken.
One alternative is translating here after every semantic action,
but that translation would be missed if the semantic action invokes
YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or
if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an
incorrect destructor might then be invoked immediately. In the
case of YYERROR or YYBACKUP, subsequent parser actions might lead
to an incorrect destructor call or verbose syntax error message
before the lookahead is translated. */
YY_SYMBOL_PRINT ("-> $$ =", YY_CAST (yysymbol_kind_t, yyr1[yyn]), &yyval, &yyloc);
YYPOPSTACK (yylen);
yylen = 0;
*++yyvsp = yyval;
*++yylsp = yyloc;
/* Now 'shift' the result of the reduction. Determine what state
that goes to, based on the state we popped back to and the rule
number reduced by. */
{
const int yylhs = yyr1[yyn] - YYNTOKENS;
const int yyi = yypgoto[yylhs] + *yyssp;
yystate = (0 <= yyi && yyi <= YYLAST && yycheck[yyi] == *yyssp
? yytable[yyi]
: yydefgoto[yylhs]);
}
goto yynewstate;
/*--------------------------------------.
| yyerrlab -- here on detecting error. |
`--------------------------------------*/
yyerrlab:
/* Make sure we have latest lookahead translation. See comments at
user semantic actions for why this is necessary. */
yytoken = yychar == YYEMPTY ? YYSYMBOL_YYEMPTY : YYTRANSLATE (yychar);
/* If not already recovering from an error, report this error. */
if (!yyerrstatus)
{
yyerror (&yylloc, info, YY_("syntax error"));
}
yyerror_range[1] = yylloc;
if (yyerrstatus == 3)
{
/* If just tried and failed to reuse lookahead token after an
error, discard it. */
if (yychar <= YYEOF)
{
/* Return failure if at end of input. */
if (yychar == YYEOF)
YYABORT;
}
else
{
yydestruct ("Error: discarding",
yytoken, &yylval, &yylloc, info);
yychar = YYEMPTY;
}
}
/* Else will try to reuse lookahead token after shifting the error
token. */
goto yyerrlab1;
/*---------------------------------------------------.
| yyerrorlab -- error raised explicitly by YYERROR. |
`---------------------------------------------------*/
yyerrorlab:
/* Pacify compilers when the user code never invokes YYERROR and the
label yyerrorlab therefore never appears in user code. */
if (0)
YYERROR;
/* Do not reclaim the symbols of the rule whose action triggered
this YYERROR. */
YYPOPSTACK (yylen);
yylen = 0;
YY_STACK_PRINT (yyss, yyssp);
yystate = *yyssp;
goto yyerrlab1;
/*-------------------------------------------------------------.
| yyerrlab1 -- common code for both syntax error and YYERROR. |
`-------------------------------------------------------------*/
yyerrlab1:
yyerrstatus = 3; /* Each real token shifted decrements this. */
/* Pop stack until we find a state that shifts the error token. */
for (;;)
{
yyn = yypact[yystate];
if (!yypact_value_is_default (yyn))
{
yyn += YYSYMBOL_YYerror;
if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYSYMBOL_YYerror)
{
yyn = yytable[yyn];
if (0 < yyn)
break;
}
}
/* Pop the current state because it cannot handle the error token. */
if (yyssp == yyss)
YYABORT;
yyerror_range[1] = *yylsp;
yydestruct ("Error: popping",
YY_ACCESSING_SYMBOL (yystate), yyvsp, yylsp, info);
YYPOPSTACK (1);
yystate = *yyssp;
YY_STACK_PRINT (yyss, yyssp);
}
YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN
*++yyvsp = yylval;
YY_IGNORE_MAYBE_UNINITIALIZED_END
yyerror_range[2] = yylloc;
++yylsp;
YYLLOC_DEFAULT (*yylsp, yyerror_range, 2);
/* Shift the error token. */
YY_SYMBOL_PRINT ("Shifting", YY_ACCESSING_SYMBOL (yyn), yyvsp, yylsp);
yystate = yyn;
goto yynewstate;
/*-------------------------------------.
| yyacceptlab -- YYACCEPT comes here. |
`-------------------------------------*/
yyacceptlab:
yyresult = 0;
goto yyreturnlab;
/*-----------------------------------.
| yyabortlab -- YYABORT comes here. |
`-----------------------------------*/
yyabortlab:
yyresult = 1;
goto yyreturnlab;
/*-----------------------------------------------------------.
| yyexhaustedlab -- YYNOMEM (memory exhaustion) comes here. |
`-----------------------------------------------------------*/
yyexhaustedlab:
yyerror (&yylloc, info, YY_("memory exhausted"));
yyresult = 2;
goto yyreturnlab;
/*----------------------------------------------------------.
| yyreturnlab -- parsing is finished, clean up and return. |
`----------------------------------------------------------*/
yyreturnlab:
if (yychar != YYEMPTY)
{
/* Make sure we have latest lookahead translation. See comments at
user semantic actions for why this is necessary. */
yytoken = YYTRANSLATE (yychar);
yydestruct ("Cleanup: discarding lookahead",
yytoken, &yylval, &yylloc, info);
}
/* Do not reclaim the symbols of the rule whose action triggered
this YYABORT or YYACCEPT. */
YYPOPSTACK (yylen);
YY_STACK_PRINT (yyss, yyssp);
while (yyssp != yyss)
{
yydestruct ("Cleanup: popping",
YY_ACCESSING_SYMBOL (+*yyssp), yyvsp, yylsp, info);
YYPOPSTACK (1);
}
#ifndef yyoverflow
if (yyss != yyssa)
YYSTACK_FREE (yyss);
#endif
return yyresult;
}
/*
* Month and day table.
*/
static const TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
{ "april", tMONTH, 4 },
{ "may", tMONTH, 5 },
{ "june", tMONTH, 6 },
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 0 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
{ NULL, 0, 0 }
};
/*
* Time units table.
*/
static const TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
{ "week", tDAY_UNIT, 7 },
{ "day", tDAY_UNIT, 1 },
{ "hour", tSEC_UNIT, 60 * 60 },
{ "minute", tSEC_UNIT, 60 },
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
{ NULL, 0, 0 }
};
/*
* Assorted relative-time words.
*/
static const TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
#if 0
{ "first", tUNUMBER, 1 },
{ "second", tUNUMBER, 2 },
{ "third", tUNUMBER, 3 },
{ "fourth", tUNUMBER, 4 },
{ "fifth", tUNUMBER, 5 },
{ "sixth", tUNUMBER, 6 },
{ "seventh", tUNUMBER, 7 },
{ "eighth", tUNUMBER, 8 },
{ "ninth", tUNUMBER, 9 },
{ "tenth", tUNUMBER, 10 },
{ "eleventh", tUNUMBER, 11 },
{ "twelfth", tUNUMBER, 12 },
#endif
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
{ NULL, 0, 0 }
};
/*
* The timezone table. (Note: This table was modified to not use any floating
* point constants to work around an SGI compiler bug).
*/
static const TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
{ "wet", tZONE, HOUR( 0) }, /* Western European */
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
{ "at", tZONE, HOUR( 2) }, /* Azores */
#if 0
/* For completeness. BST is also British Summer, and GST is
* also Guam Standard. */
{ "bst", tZONE, HOUR( 3) }, /* Brazil Standard */
{ "gst", tZONE, HOUR( 3) }, /* Greenland Standard */
#endif
{ "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */
{ "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */
{ "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
{ "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */
{ "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
{ "est", tZONE, HOUR( 5) }, /* Eastern Standard */
{ "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
{ "cst", tZONE, HOUR( 6) }, /* Central Standard */
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "akst", tZONE, HOUR( 9) }, /* Alaska Standard */
{ "akdt", tDAYZONE, HOUR( 9) }, /* Alaska Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
{ "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */
{ "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */
{ "fwt", tZONE, -HOUR( 1) }, /* French Winter */
{ "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */
{ "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
{ "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
{ "it", tZONE, -HOUR( 7/2) }, /* Iran */
{ "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
{ "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
{ "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */
{ "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
#if 0
/* For completeness. NST is also Newfoundland Standard, and SST is
* also Swedish Summer. */
{ "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
{ "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
{ "idle", tZONE, -HOUR(12) }, /* International Date Line East */
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
{ NULL, 0, 0 }
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
static time_t
ToSeconds(
time_t Hours,
time_t Minutes,
time_t Seconds,
MERIDIAN Meridian)
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) {
return -1;
}
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23) {
return -1;
}
return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12) {
return -1;
}
return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12) {
return -1;
}
return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
if (strlen(buff) == 3) {
abbrev = 1;
} else if (strlen(buff) == 4 && buff[3] == '.') {
abbrev = 1;
buff[3] = '\0';
} else {
abbrev = 0;
}
for (tp = MonthDayTable; tp->name; tp++) {
if (abbrev) {
if (strncmp(buff, tp->name, 3) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
} else if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
/*
* Strip off any plural and try the units table again.
*/
i = strlen(buff) - 1;
if (i > 0 && buff[i] == 's') {
buff[i] = '\0';
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
for (tp = OtherTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
/*
* Military timezones.
*/
if (buff[1] == '\0' && !(*buff & 0x80)
&& isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
/*
* Drop out any periods and try the timezone table again.
*/
for (i = 0, p = q = buff; *q; q++) {
if (*q != '.') {
*p++ = *q;
} else {
i++;
}
}
*p = '\0';
if (i) {
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
return tID;
}
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
Count = 0;
for (yylvalPtr->Number = 0;
isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
yylvalPtr->Number = 10 * yylvalPtr->Number + c - '0';
Count++;
}
yyInput--;
yyDigitCount = Count;
/*
* A number with 6 or more digits is considered an ISO 8601 base.
*/
if (Count >= 6) {
location->last_column = yyInput - info->dateStart - 1;
return tISOBASE;
} else {
location->last_column = yyInput - info->dateStart - 1;
return tUNUMBER;
}
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
return LookupWord(yylvalPtr, buff);
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
Count = 0;
do {
c = *yyInput++;
if (c == '\0') {
location->last_column = yyInput - info->dateStart - 1;
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"stringToParse baseYear baseMonth baseDay" );
return TCL_ERROR;
}
yyInput = TclGetString(objv[1]);
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &da) != TCL_OK) {
return TCL_ERROR;
}
yyYear = yr; yyMonth = mo; yyDay = da;
yyHaveTime = 0;
yyHour = 0; yyMinutes = 0; yySeconds = 0; yyMeridian = MER24;
yyHaveZone = 0;
yyTimezone = 0; yyDSTmode = DSTmaybe;
yyHaveOrdinalMonth = 0;
yyMonthOrdinal = 0;
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
TclNewObj(dateInfo.messages);
dateInfo.separatrix = "";
Tcl_IncrRefCount(dateInfo.messages);
status = yyparse(&dateInfo);
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
return TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
"from date parser. Please "
"report this error as a "
"bug in Tcl.", -1));
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL);
return TCL_ERROR;
}
Tcl_DecrRefCount(dateInfo.messages);
if (yyHaveDate > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one date in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveTime > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time of day in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveZone > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time zone in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveDay > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one weekday in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
TclNewObj(result);
TclNewObj(resultElement);
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
TclNewObj(resultElement);
Tcl_ListObjAppendElement(interp, result, resultElement);
}
TclNewObj(resultElement);
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(-yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
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 | /* * tclDecls.h -- * * Declarations of functions in the platform independent public Tcl API. * * 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. */ #ifndef _TCLDECLS #define _TCLDECLS #include <stddef.h> /* for size_t */ #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif #if !defined(BUILD_tcl) # define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) | > > > > > > > > > < < | | 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 | /* * tclDecls.h -- * * Declarations of functions in the platform independent public Tcl API. * * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLDECLS #define _TCLDECLS #include <stddef.h> /* for size_t */ #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif #if !defined(BUILD_tcl) # define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) #else # define TCL_DEPRECATED(msg) MODULE_SCOPE #endif /* * 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/tcl.decls script. |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 | EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 39 */ EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); | | < | < < < | < < | 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 | EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 39 */ EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); /* Slot 41 is reserved */ /* 42 */ EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr); /* 43 */ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 44 */ EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* Slot 45 is reserved */ /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* Slot 47 is reserved */ /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ |
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 |
/* 688 */
EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue);
/* 689 */
EXTERN void Tcl_SetWideUIntObj(Tcl_Obj *objPtr,
Tcl_WideUInt uwideValue);
/* 690 */
EXTERN void TclUnusedStubEntry(void);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/* 688 */
EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue);
/* 689 */
EXTERN void Tcl_SetWideUIntObj(Tcl_Obj *objPtr,
Tcl_WideUInt uwideValue);
/* 690 */
EXTERN void TclUnusedStubEntry(void);
/* 691 */
EXTERN Tcl_ObjInterface * Tcl_NewObjInterface(void);
/* 692 */
EXTERN Tcl_ObjType * Tcl_NewObjType(void);
/* 693 */
EXTERN int Tcl_ObjInterfaceSetVersion(Tcl_ObjInterface *oiPtr,
int version);
/* 694 */
EXTERN int Tcl_ObjTypeSetFreeInternalRepProc(Tcl_ObjType *otPtr,
Tcl_FreeInternalRepProc *freeIntRepProc);
/* 695 */
EXTERN int Tcl_ObjTypeSetDupInternalRepProc(Tcl_ObjType *otPtr,
Tcl_DupInternalRepProc *dupIntRepProc);
/* 696 */
EXTERN int Tcl_ObjTypeSetUpdateStringProc(Tcl_ObjType *otPtr,
Tcl_UpdateStringProc *updateStringProc);
/* 697 */
EXTERN int Tcl_ObjTypeSetSetFromAnyProc(Tcl_ObjType *otPtr,
Tcl_SetFromAnyProc *setFromAnyProc);
/* 698 */
EXTERN int Tcl_ObjTypeSetVersion(Tcl_ObjType *otPtr,
int version);
/* 699 */
EXTERN int Tcl_ObjInterfaceSetFnListAll(Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListAllProc *fnPtr);
/* 700 */
EXTERN int Tcl_ObjInterfaceSetFnListAppend(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListAppendProc *fnPtr);
/* 701 */
EXTERN int Tcl_ObjInterfaceSetFnListAppendList(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListAppendlistProc fnPtr);
/* 702 */
EXTERN int Tcl_ObjInterfaceSetFnListIndex(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListIndexProc fnPtr);
/* 703 */
EXTERN int Tcl_ObjInterfaceSetFnListIndexEnd(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListIndexEndProc fnPtr);
/* 704 */
EXTERN int Tcl_ObjInterfaceSetFnListIsSorted(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListIsSortedProc fnPtr);
/* 705 */
EXTERN int Tcl_ObjInterfaceSetFnListLength(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListLengthProc fnPtr);
/* 706 */
EXTERN int Tcl_ObjInterfaceSetFnListRange(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListRangeProc fnPtr);
/* 707 */
EXTERN int Tcl_ObjInterfaceSetFnListRangeEnd(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListRangeEndProc fnPtr);
/* 708 */
EXTERN int Tcl_ObjInterfaceSetFnListReplace(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListReplaceProc fnPtr);
/* 709 */
EXTERN int Tcl_ObjInterfaceSetFnListReplaceList(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListReplaceListProc fnPtr);
/* 710 */
EXTERN int Tcl_ObjInterfaceSetFnListReverse(
Tcl_ObjInterface *objInterfacePtr,
Tcl_ObjInterfaceListReverseProc fnPtr);
/* 711 */
EXTERN int Tcl_ObjInterfaceSetFnListSet(Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListSetProc fnPtr);
/* 712 */
EXTERN int Tcl_ObjInterfaceSetFnListSetDeep(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListSetDeepProc fnPtr);
/* 713 */
EXTERN int Tcl_ObjInterfaceSetFnStringIndex(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringIndexProc fnPtr);
/* 714 */
EXTERN int Tcl_ObjInterfaceSetFnStringIndexEnd(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringIndexEndProc fnPtr);
/* 715 */
EXTERN int Tcl_ObjInterfaceSetFnStringLength(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringLengthProc fnPtr);
/* 716 */
EXTERN int Tcl_ObjInterfaceSetFnStringRange(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringRangeProc fnPtr);
/* 717 */
EXTERN int Tcl_ObjInterfaceSetFnStringRangeEnd(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringRangeEndProc fnPtr);
/* 718 */
EXTERN int Tcl_ObjTypeSetInterface(Tcl_ObjType *objTypePtr,
Tcl_ObjInterface *objInterfacePtr);
/* 719 */
EXTERN int Tcl_ObjTypeSetName(Tcl_ObjType *objTypePtr,
char *name);
/* 720 */
EXTERN int Tcl_ObjInterfaceSetFnStringIsEmpty(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceStringIsEmptyProc fnPtr);
/* 721 */
EXTERN int Tcl_ObjInterfaceSetFnListContains(
Tcl_ObjInterface *oiPtr,
Tcl_ObjInterfaceListContainsProc fnPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
|
| ︙ | ︙ | |||
1921 1922 1923 1924 1925 1926 1927 |
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
void (*reserved36)(void);
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */
| | | | | 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 |
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
void (*reserved36)(void);
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */
void (*reserved41)(void);
void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */
int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */
int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */
void (*reserved45)(void);
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */
void (*reserved47)(void);
int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */
void (*reserved49)(void);
Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
void (*reserved52)(void);
Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */
void (*reserved54)(void);
|
| ︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 |
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */
int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */
Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */
void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */
void (*tclUnusedStubEntry) (void); /* 690 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */
Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */
int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */
int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */
Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */
void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */
void (*tclUnusedStubEntry) (void); /* 690 */
Tcl_ObjInterface * (*tcl_NewObjInterface) (void); /* 691 */
Tcl_ObjType * (*tcl_NewObjType) (void); /* 692 */
int (*tcl_ObjInterfaceSetVersion) (Tcl_ObjInterface *oiPtr, int version); /* 693 */
int (*tcl_ObjTypeSetFreeInternalRepProc) (Tcl_ObjType *otPtr, Tcl_FreeInternalRepProc *freeIntRepProc); /* 694 */
int (*tcl_ObjTypeSetDupInternalRepProc) (Tcl_ObjType *otPtr, Tcl_DupInternalRepProc *dupIntRepProc); /* 695 */
int (*tcl_ObjTypeSetUpdateStringProc) (Tcl_ObjType *otPtr, Tcl_UpdateStringProc *updateStringProc); /* 696 */
int (*tcl_ObjTypeSetSetFromAnyProc) (Tcl_ObjType *otPtr, Tcl_SetFromAnyProc *setFromAnyProc); /* 697 */
int (*tcl_ObjTypeSetVersion) (Tcl_ObjType *otPtr, int version); /* 698 */
int (*tcl_ObjInterfaceSetFnListAll) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListAllProc *fnPtr); /* 699 */
int (*tcl_ObjInterfaceSetFnListAppend) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListAppendProc *fnPtr); /* 700 */
int (*tcl_ObjInterfaceSetFnListAppendList) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListAppendlistProc fnPtr); /* 701 */
int (*tcl_ObjInterfaceSetFnListIndex) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListIndexProc fnPtr); /* 702 */
int (*tcl_ObjInterfaceSetFnListIndexEnd) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListIndexEndProc fnPtr); /* 703 */
int (*tcl_ObjInterfaceSetFnListIsSorted) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListIsSortedProc fnPtr); /* 704 */
int (*tcl_ObjInterfaceSetFnListLength) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListLengthProc fnPtr); /* 705 */
int (*tcl_ObjInterfaceSetFnListRange) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListRangeProc fnPtr); /* 706 */
int (*tcl_ObjInterfaceSetFnListRangeEnd) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListRangeEndProc fnPtr); /* 707 */
int (*tcl_ObjInterfaceSetFnListReplace) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListReplaceProc fnPtr); /* 708 */
int (*tcl_ObjInterfaceSetFnListReplaceList) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListReplaceListProc fnPtr); /* 709 */
int (*tcl_ObjInterfaceSetFnListReverse) (Tcl_ObjInterface *objInterfacePtr, Tcl_ObjInterfaceListReverseProc fnPtr); /* 710 */
int (*tcl_ObjInterfaceSetFnListSet) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListSetProc fnPtr); /* 711 */
int (*tcl_ObjInterfaceSetFnListSetDeep) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListSetDeepProc fnPtr); /* 712 */
int (*tcl_ObjInterfaceSetFnStringIndex) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringIndexProc fnPtr); /* 713 */
int (*tcl_ObjInterfaceSetFnStringIndexEnd) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringIndexEndProc fnPtr); /* 714 */
int (*tcl_ObjInterfaceSetFnStringLength) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringLengthProc fnPtr); /* 715 */
int (*tcl_ObjInterfaceSetFnStringRange) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringRangeProc fnPtr); /* 716 */
int (*tcl_ObjInterfaceSetFnStringRangeEnd) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringRangeEndProc fnPtr); /* 717 */
int (*tcl_ObjTypeSetInterface) (Tcl_ObjType *objTypePtr, Tcl_ObjInterface *objInterfacePtr); /* 718 */
int (*tcl_ObjTypeSetName) (Tcl_ObjType *objTypePtr, char *name); /* 719 */
int (*tcl_ObjInterfaceSetFnStringIsEmpty) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceStringIsEmptyProc fnPtr); /* 720 */
int (*tcl_ObjInterfaceSetFnListContains) (Tcl_ObjInterface *oiPtr, Tcl_ObjInterfaceListContainsProc fnPtr); /* 721 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 | (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #define Tcl_GetLongFromObj \ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #define Tcl_GetObjType \ (tclStubsPtr->tcl_GetObjType) /* 40 */ | | < | < < < > | 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 | (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #define Tcl_GetLongFromObj \ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #define Tcl_GetObjType \ (tclStubsPtr->tcl_GetObjType) /* 40 */ /* Slot 41 is reserved */ #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ /* Slot 45 is reserved */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ /* Slot 47 is reserved */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ /* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ |
| ︙ | ︙ | |||
3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 | (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define Tcl_NewWideUIntObj \ (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ #define TclUnusedStubEntry \ (tclStubsPtr->tclUnusedStubEntry) /* 690 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TclUnusedStubEntry | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 | (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define Tcl_NewWideUIntObj \ (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ #define TclUnusedStubEntry \ (tclStubsPtr->tclUnusedStubEntry) /* 690 */ #define Tcl_NewObjInterface \ (tclStubsPtr->tcl_NewObjInterface) /* 691 */ #define Tcl_NewObjType \ (tclStubsPtr->tcl_NewObjType) /* 692 */ #define Tcl_ObjInterfaceSetVersion \ (tclStubsPtr->tcl_ObjInterfaceSetVersion) /* 693 */ #define Tcl_ObjTypeSetFreeInternalRepProc \ (tclStubsPtr->tcl_ObjTypeSetFreeInternalRepProc) /* 694 */ #define Tcl_ObjTypeSetDupInternalRepProc \ (tclStubsPtr->tcl_ObjTypeSetDupInternalRepProc) /* 695 */ #define Tcl_ObjTypeSetUpdateStringProc \ (tclStubsPtr->tcl_ObjTypeSetUpdateStringProc) /* 696 */ #define Tcl_ObjTypeSetSetFromAnyProc \ (tclStubsPtr->tcl_ObjTypeSetSetFromAnyProc) /* 697 */ #define Tcl_ObjTypeSetVersion \ (tclStubsPtr->tcl_ObjTypeSetVersion) /* 698 */ #define Tcl_ObjInterfaceSetFnListAll \ (tclStubsPtr->tcl_ObjInterfaceSetFnListAll) /* 699 */ #define Tcl_ObjInterfaceSetFnListAppend \ (tclStubsPtr->tcl_ObjInterfaceSetFnListAppend) /* 700 */ #define Tcl_ObjInterfaceSetFnListAppendList \ (tclStubsPtr->tcl_ObjInterfaceSetFnListAppendList) /* 701 */ #define Tcl_ObjInterfaceSetFnListIndex \ (tclStubsPtr->tcl_ObjInterfaceSetFnListIndex) /* 702 */ #define Tcl_ObjInterfaceSetFnListIndexEnd \ (tclStubsPtr->tcl_ObjInterfaceSetFnListIndexEnd) /* 703 */ #define Tcl_ObjInterfaceSetFnListIsSorted \ (tclStubsPtr->tcl_ObjInterfaceSetFnListIsSorted) /* 704 */ #define Tcl_ObjInterfaceSetFnListLength \ (tclStubsPtr->tcl_ObjInterfaceSetFnListLength) /* 705 */ #define Tcl_ObjInterfaceSetFnListRange \ (tclStubsPtr->tcl_ObjInterfaceSetFnListRange) /* 706 */ #define Tcl_ObjInterfaceSetFnListRangeEnd \ (tclStubsPtr->tcl_ObjInterfaceSetFnListRangeEnd) /* 707 */ #define Tcl_ObjInterfaceSetFnListReplace \ (tclStubsPtr->tcl_ObjInterfaceSetFnListReplace) /* 708 */ #define Tcl_ObjInterfaceSetFnListReplaceList \ (tclStubsPtr->tcl_ObjInterfaceSetFnListReplaceList) /* 709 */ #define Tcl_ObjInterfaceSetFnListReverse \ (tclStubsPtr->tcl_ObjInterfaceSetFnListReverse) /* 710 */ #define Tcl_ObjInterfaceSetFnListSet \ (tclStubsPtr->tcl_ObjInterfaceSetFnListSet) /* 711 */ #define Tcl_ObjInterfaceSetFnListSetDeep \ (tclStubsPtr->tcl_ObjInterfaceSetFnListSetDeep) /* 712 */ #define Tcl_ObjInterfaceSetFnStringIndex \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringIndex) /* 713 */ #define Tcl_ObjInterfaceSetFnStringIndexEnd \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringIndexEnd) /* 714 */ #define Tcl_ObjInterfaceSetFnStringLength \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringLength) /* 715 */ #define Tcl_ObjInterfaceSetFnStringRange \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringRange) /* 716 */ #define Tcl_ObjInterfaceSetFnStringRangeEnd \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringRangeEnd) /* 717 */ #define Tcl_ObjTypeSetInterface \ (tclStubsPtr->tcl_ObjTypeSetInterface) /* 718 */ #define Tcl_ObjTypeSetName \ (tclStubsPtr->tcl_ObjTypeSetName) /* 719 */ #define Tcl_ObjInterfaceSetFnStringIsEmpty \ (tclStubsPtr->tcl_ObjInterfaceSetFnStringIsEmpty) /* 720 */ #define Tcl_ObjInterfaceSetFnListContains \ (tclStubsPtr->tcl_ObjInterfaceSetFnListContains) /* 721 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TclUnusedStubEntry |
| ︙ | ︙ | |||
4028 4029 4030 4031 4032 4033 4034 | #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj #undef Tcl_GetBoolean | < | | | < | > | > | | < < | | > > > > | < < < | < < < > | 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 |
#define Tcl_GetString(objPtr) \
Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL)
#define Tcl_GetUnicode(objPtr) \
Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL)
#undef Tcl_GetIndexFromObjStruct
#undef Tcl_GetBooleanFromObj
#undef Tcl_GetBoolean
#if !defined(__cplusplus) && !defined(BUILD_tcl) && !defined(BUILD_tk) && !defined(_MSC_VER)
# define TCLBOOLWARNING(boolPtr) (void)(sizeof(struct {_Static_assert(sizeof(*(boolPtr)) <= sizeof(int), "sizeof(boolPtr) too large");int dummy;})),
#elif defined(__GNUC__)
/* If this gives: "error: size of array ‘_bool_Var’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */
# define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}),
#else
# define TCLBOOLWARNING(boolPtr)
#endif
#if defined(USE_TCL_STUBS)
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg,\
flags, indexPtr) \
(tclStubsPtr->tcl_GetIndexFromObjStruct(\
(interp), (objPtr), (tablePtr), (offset), (msg), \
(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
(Tcl_GetBoolFromObj(interp, objPtr,\
(TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
(Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof(\
(*(boolPtr))), (char *)(boolPtr)))
#undef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(tclStubsPtr->tcl_GetBytesFromObj(\
NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#else
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#undef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr))
#endif
#ifdef TCL_MEM_DEBUG
# undef Tcl_Alloc
# define Tcl_Alloc(x) \
(Tcl_DbCkalloc((x), __FILE__, __LINE__))
# undef Tcl_Free
|
| ︙ | ︙ | |||
4090 4091 4092 4093 4094 4095 4096 | #define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) #define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 | #define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) #define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) # define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) |
| ︙ | ︙ | |||
4159 4160 4161 4162 4163 4164 4165 |
*/
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
| < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 |
*/
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
# undef Tcl_Close
# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#undef TclUtfCharComplete
#undef TclUtfNext
#undef TclUtfPrev
#endif /* _TCLDECLS */
|
1 | /* | < < < < < > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2002-2010 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Copyright © 2024 Nathan Coulter. * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclDictObj.c -- * * This file contains functions that implement the Tcl dict object type * and its accessor command. */ #include "tclInt.h" #include "tclTomMath.h" #include <assert.h> /* * Forward declaration. */ |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
| > > > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
static Tcl_ObjInterfaceListLengthProc DictAsListLength;
/* static Tcl_ObjInterfaceListIndexProc DictAsListIndex; */
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
size_t epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
| > > | > > > > > > | > > | | | | | 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 |
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
size_t epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
int dupedKeys; /* Whether there are duplicate keys in the
* dictionary */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
ObjInterface dictObjInterface;
static ObjectType tclDictObjectType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny, /* setFromAnyProc */
2,
NULL
};
Tcl_ObjType *tclDictTypePtr = (Tcl_ObjType *)&tclDictObjectType;
#define DictSetInternalRep(objPtr, dictRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), tclDictTypePtr, &ir); \
} while (0)
#define DictGetInternalRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), tclDictTypePtr); \
(dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
* allocates a bit more space in each hash entry in order to hold the pointers
* used to keep the hash entries in a linked list.
*
* Note that this type of hash table is *only* suitable for direct use in
* *this* file. Everything else should use the dict iterator API.
*/
static const Tcl_HashKeyType chainHashType = {
TCL_HASH_KEY_TYPE_VERSION,
TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */
TclHashObjKey,
TclCompareObjKeys,
AllocChainEntry,
TclFreeObjEntry
};
/*
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
* 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 --
| > > > > > > > > > | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
* 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;
void TclDictInit(void) {
Tcl_ObjInterface *oiPtr;
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListLength(oiPtr ,DictAsListLength);
Tcl_ObjTypeSetInterface(tclDictTypePtr ,oiPtr);
return;
}
/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
/*
*----------------------------------------------------------------------
*
* AllocChainEntry --
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | /* * Assume that cPtr is never NULL since we know the number of array * elements already. */ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); | | | | | | 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 |
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = Tcl_GetStringFromObj(keyPtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = Tcl_GetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
}
bytesNeeded += numElems;
/*
* Pass 2: copy into string rep buffer.
*/
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = Tcl_GetStringFromObj(keyPtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = Tcl_GetStringFromObj(valuePtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
/* Last space overwrote the terminating NUL; cal T_ISR again to restore */
(void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
Dict *dict = (Dict *)Tcl_Alloc(sizeof(Dict));
InitChainTable(dict);
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
*/
| > | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
Dict *dict = (Dict *)Tcl_Alloc(sizeof(Dict));
dict->dupedKeys = 0;
InitChainTable(dict);
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
*/
if (TclHasInternalRep(objPtr, tclListTypePtr)) {
Tcl_Size objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
TclListObjGetElements(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 | Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr); /* * Not really a well-formed dictionary as there are duplicate * keys, so better get the string rep here so that we can * convert back. */ | < > | | 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 |
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
/*
* Not really a well-formed dictionary as there are duplicate
* keys, so better get the string rep here so that we can
* convert back.
*/
(void) TclGetString(objPtr);
dict->dupedKeys = 1;
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
}
} else {
Tcl_Size length;
const char *nextElem = Tcl_GetStringFromObj(objPtr, &length);
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
Tcl_Size elemSize;
int literal;
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(keyPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, valuePtr);
Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
}
}
| > | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
dict->dupedKeys = 1;
TclDecrRefCount(keyPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, valuePtr);
Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
}
}
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
return NULL;
}
DictGetInternalRep(dictPtr, dict);
}
return dict;
}
/*
*----------------------------------------------------------------------
*
* TclTraceDictPath --
*
* Trace through a tree of dictionaries using the array of keys given. If
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
return NULL;
}
DictGetInternalRep(dictPtr, dict);
}
return dict;
}
/*
*----------------------------------------------------------------------
*
* TclDictObjSmartRef --
*
* This function returns new tcl-object with the smart reference to
* dictionary object.
*
* Object returned with this function is a smart reference (pointer),
* so new object of type tclDictType, that directly references given
* dictionary object (with internally increased refCount).
*
* The usage of such pointer objects allows to hold more as one
* reference to the same real dictionary object, allows to make a pointer
* to part of another dictionary, allows to change the dictionary without
* regarding of the "shared" state of the dictionary object.
*
* Prevents "called with shared object" exception if object is multiple
* referenced.
*
* Results:
* The newly create object (contains smart reference) is returned.
* The returned object has a ref count of 0.
*
* Side effects:
* Increases ref count of the referenced dictionary.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclDictObjSmartRef(
Tcl_Interp *interp,
Tcl_Obj *dictPtr)
{
Tcl_Obj *result;
Dict *dict;
if (!TclHasInternalRep(dictPtr, tclDictTypePtr)
&& SetDictFromAny(interp, dictPtr) != TCL_OK) {
return NULL;
}
DictGetInternalRep(dictPtr, dict);
result = Tcl_NewObj();
DictSetInternalRep(result, dict);
dict->refCount++;
result->internalRep.twoPtrValue.ptr2 = NULL;
result->typePtr = tclDictTypePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclTraceDictPath --
*
* Trace through a tree of dictionaries using the array of keys given. If
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 | * Removes a reference to the dictionary's internal rep. * *---------------------------------------------------------------------- */ void Tcl_DictObjDone( | | | 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
* Removes a reference to the dictionary's internal rep.
*
*----------------------------------------------------------------------
*/
void
Tcl_DictObjDone(
Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */
{
Dict *dict;
if (searchPtr->epoch) {
searchPtr->epoch = 0;
dict = (Dict *) searchPtr->dictionaryPtr;
if (dict->refCount-- <= 1) {
|
| ︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 |
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
}
if (keyc < 1) {
Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
}
| | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
}
if (keyc < 1) {
Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_CREATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
DictGetInternalRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
}
if (keyc < 1) {
Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList");
}
| | | 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 |
if (Tcl_IsShared(dictPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
}
if (keyc < 1) {
Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList");
}
dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1, keyv, DICT_PATH_UPDATE);
if (dictPtr == NULL) {
return TCL_ERROR;
}
DictGetInternalRep(dictPtr, dict);
assert(dict != NULL);
DeleteChainEntry(dict, keyv[keyc-1]);
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictCreateCmd( | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictCreateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictObj;
int i;
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetCmd( | | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr = NULL;
int result;
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
* Loop through the list of keys, looking up the key at the current index
* in the current dictionary each time. Once we've done the lookup, we set
* the current dictionary to be the value we looked up (in case the value
* was not the last one and we are going through a chain of searches.)
* Note that this loop always executes at least once.
*/
| | | 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 |
* Loop through the list of keys, looking up the key at the current index
* in the current dictionary each time. Once we've done the lookup, we set
* the current dictionary to be the value we looked up (in case the value
* was not the last one and we are going through a chain of searches.)
* Note that this loop always executes at least once.
*/
dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, DICT_PATH_READ);
if (dictPtr == NULL) {
return TCL_ERROR;
}
result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
if (result != TCL_OK) {
return result;
}
|
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetDefCmd( | | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
Tcl_Obj *const *keyPath;
int numKeys;
|
| ︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictReplaceCmd( | | | 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictReplaceCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictRemoveCmd( | | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictRemoveCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMergeCmd( | | | 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMergeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
int allocatedDict = 0;
int i, done;
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictKeysCmd( | | | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictKeysCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *listPtr;
const char *pattern = NULL;
|
| ︙ | ︙ | |||
2123 2124 2125 2126 2127 2128 2129 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictValuesCmd( | | | 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictValuesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *valuePtr = NULL, *listPtr;
Tcl_DictSearch search;
int done;
|
| ︙ | ︙ | |||
2149 2150 2151 2152 2153 2154 2155 |
if (objc == 3) {
pattern = TclGetString(objv[2]);
} else {
pattern = NULL;
}
listPtr = Tcl_NewListObj(0, NULL);
for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
| | | 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 |
if (objc == 3) {
pattern = TclGetString(objv[2]);
} else {
pattern = NULL;
}
listPtr = Tcl_NewListObj(0, NULL);
for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
if (pattern==NULL || Tcl_StringMatch(TclGetString(valuePtr), pattern)) {
/*
* Assume this operation always succeeds.
*/
Tcl_ListObjAppendElement(interp, listPtr, valuePtr);
}
}
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSizeCmd( | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result;
Tcl_Size size;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
result = Tcl_DictObjSize(interp, objv[1], &size);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(size));
}
return result;
}
/*
*----------------------------------------------------------------------
*
* DictExistsCmd --
|
| ︙ | ︙ | |||
2276 2277 2278 2279 2280 2281 2282 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictExistsCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
return TCL_ERROR;
}
dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2, DICT_PATH_EXISTS);
if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT ||
Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
} else {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
}
return TCL_OK;
|
| ︙ | ︙ | |||
2318 2319 2320 2321 2322 2323 2324 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictInfoCmd( | | | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictInfoCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Dict *dict;
char *statsStr;
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictIncrCmd( | | | 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictIncrCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int code = TCL_OK;
Tcl_Obj *dictPtr, *valuePtr = NULL;
|
| ︙ | ︙ | |||
2483 2484 2485 2486 2487 2488 2489 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictLappendCmd( | | | 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictLappendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0, allocatedValue = 0;
|
| ︙ | ︙ | |||
2570 2571 2572 2573 2574 2575 2576 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictAppendCmd( | | | 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictAppendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int allocatedDict = 0;
|
| ︙ | ︙ | |||
2672 2673 2674 2675 2676 2677 2678 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictForNRCmd( | | | 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictForNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
|
| ︙ | ︙ | |||
2868 2869 2870 2871 2872 2873 2874 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMapNRCmd( | | | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMapNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
|
| ︙ | ︙ | |||
2953 2954 2955 2956 2957 2958 2959 |
}
TclDecrRefCount(valueObj);
/*
* Run the script.
*/
| | | 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
}
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.
*/
|
| ︙ | ︙ | |||
3043 3044 3045 3046 3047 3048 3049 |
}
TclDecrRefCount(valueObj);
/*
* Run the script.
*/
| | | 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 |
}
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.
*/
|
| ︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSetCmd( | | | 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
3141 3142 3143 3144 3145 3146 3147 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUnsetCmd( | | | 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUnsetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictFilterCmd( | | | 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictFilterCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
static const char *const filters[] = {
"key", "script", "value", NULL
|
| ︙ | ︙ | |||
3224 3225 3226 3227 3228 3229 3230 |
const char *pattern;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
| | | 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 |
const char *pattern;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case FILTER_KEYS:
/*
* Create a dictionary whose keys all match a certain pattern.
|
| ︙ | ︙ | |||
3486 3487 3488 3489 3490 3491 3492 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUpdateCmd( | | | 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUpdateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
int i;
|
| ︙ | ︙ | |||
3534 3535 3536 3537 3538 3539 3540 |
* Execute the body after setting up the NRE handler to process the
* results.
*/
objPtr = Tcl_NewListObj(objc-3, objv+2);
Tcl_IncrRefCount(objPtr);
Tcl_IncrRefCount(objv[1]);
| | | 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 |
* Execute the body after setting up the NRE handler to process the
* results.
*/
objPtr = Tcl_NewListObj(objc-3, objv+2);
Tcl_IncrRefCount(objPtr);
Tcl_IncrRefCount(objv[1]);
TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL, NULL);
return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
}
static int
FinalizeDictUpdate(
void *data[],
|
| ︙ | ︙ | |||
3645 3646 3647 3648 3649 3650 3651 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictWithCmd( | | | 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictWithCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
|
| ︙ | ︙ | |||
3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
*----------------------------------------------------------------------
*
* DictAsListLength --
*
* Compute the length of a list as if the dict value were converted to a
* list.
*
* Note: the list length may not match the dict size * 2. This occurs when
* there are duplicate keys in the original string representation.
*
* Side Effects --
*
* The internal representation of objPtr might be converted to list.
*
*/
static int
DictAsListLength(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size *lenPtr)
{
Tcl_Size length;
int status;
if (TclHasStringRep(objPtr)) {
status = TclSetListFromAny(interp ,objPtr);
if (status) {
/* This shouldn't be possible because any dict can be converted to
* a list*/
Tcl_Panic("%s {could not convert dictionary to list}"
, "DictAsListLength");
}
status = Tcl_ListObjLength(interp ,objPtr ,lenPtr);
return status;
} else {
status = Tcl_DictObjSize(interp ,objPtr ,&length);
if (status) {
return status;
} else {
*lenPtr = length * 2;
}
return TCL_OK;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 | /* | < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1998 Sun Microsystems, Inc. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2013-2016 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclDisassemble.c -- * * This file contains procedures that disassemble bytecode into either * human-readable or Tcl-processable forms. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
static const Tcl_ObjType instNameType = {
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
| < > | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
static const Tcl_ObjType instNameType = {
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
#define InstNameSetInternalRep(objPtr, inst) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (inst); \
Tcl_StoreInternalRep((objPtr), &instNameType, &ir); \
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
Tcl_Size length;
| | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
Tcl_Size length;
bytes = Tcl_GetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
/*
*----------------------------------------------------------------------
*
* TclPrintSource --
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
| | > | > | > | > | > | > | > | > | > | > | > | > | > | > | > | > | | 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 |
AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
opnd = TclGetInt1AtPtr(pc+numBytes);
numBytes++;
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+numBytes);
numBytes += 4;
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes);
numBytes++;
Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_UINT4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
if (opCode == INST_START_CMD) {
snprintf(suffixBuffer+strlen(suffixBuffer),
sizeof(suffixBuffer) - strlen(suffixBuffer),
", %u cmds start here", opnd);
}
Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_OFFSET1:
opnd = TclGetInt1AtPtr(pc+numBytes);
numBytes++;
snprintf(suffixBuffer, sizeof(suffixBuffer), "pc %u", pcOffset+opnd);
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_OFFSET4:
opnd = TclGetInt4AtPtr(pc+numBytes);
numBytes += 4;
if (opCode == INST_START_CMD) {
snprintf(suffixBuffer, sizeof(suffixBuffer),
"next cmd at pc %u", pcOffset+opnd);
} else {
snprintf(suffixBuffer, sizeof(suffixBuffer),
"pc %u", pcOffset+opnd);
}
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_LIT1:
opnd = TclGetUInt1AtPtr(pc+numBytes);
numBytes++;
suffixObj = codePtr->objArrayPtr[opnd];
Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_LIT4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
suffixObj = codePtr->objArrayPtr[opnd];
Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
break;
case OPERAND_AUX4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd);
auxPtr = &codePtr->auxDataArrayPtr[opnd];
break;
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes);
numBytes += 4;
if (opnd >= -1) {
Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
} else if (opnd == -2) {
Tcl_AppendPrintfToObj(bufferObj, "end ");
} else {
Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
}
break;
case OPERAND_LVT1:
opnd = TclGetUInt1AtPtr(pc+numBytes);
numBytes++;
goto printLVTindex;
case OPERAND_LVT4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
Tcl_Panic("FormatInstruction: bad local var index %u (%"
TCL_SIZE_MODIFIER "d locals)",
opnd, localCt);
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
snprintf(suffixBuffer, sizeof(suffixBuffer),
"temp var %u", opnd);
} else {
snprintf(suffixBuffer, sizeof(suffixBuffer), "var ");
suffixSrc = localPtr->name;
}
}
Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd);
break;
case OPERAND_SCLS1:
opnd = TclGetUInt1AtPtr(pc+numBytes);
numBytes++;
Tcl_AppendPrintfToObj(bufferObj, "%s ",
tclStringClassTable[opnd].name);
break;
case OPERAND_NONE:
default:
break;
}
}
if (suffixObj) {
const char *bytes;
Tcl_Size length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
PrintSourceToObj(bufferObj, suffixSrc, 40);
}
}
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
| | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
size_t inst; /* NOTE: We know this is really an unsigned char */
char *dst;
InstNameGetInternalRep(objPtr, inst);
if (inst >= LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 |
ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
| | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr);
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
for (i=0 ; i<(int)codePtr->numLitObjects ; i++) {
Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
}
/*
* Get the variables from the bytecode.
*/
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 |
* The way these are encoded in the bytecode is non-trivial; the Decode
* macro (which updates its argument and returns the next decoded value)
* handles this so that the rest of the code does not.
*/
#define Decode(ptr) \
((TclGetUInt1AtPtr(ptr) == 0xFF) \
| | | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
* The way these are encoded in the bytecode is non-trivial; the Decode
* macro (which updates its argument and returns the next decoded value)
* handles this so that the rest of the code does not.
*/
#define Decode(ptr) \
((TclGetUInt1AtPtr(ptr) == 0xFF) \
? ((ptr)+=5, TclGetInt4AtPtr((ptr)-4)) \
: ((ptr)+=1, TclGetInt1AtPtr((ptr)-1)))
TclNewObj(commands);
codeOffPtr = codePtr->codeDeltaStart;
codeLenPtr = codePtr->codeLengthStart;
srcOffPtr = codePtr->srcDeltaStart;
srcLenPtr = codePtr->srcLengthStart;
codeOffset = sourceOffset = 0;
|
| ︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 | * in order to disassemble them. * *---------------------------------------------------------------------- */ int Tcl_DisassembleObjCmd( | | | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 |
* in order to disassemble them.
*
*----------------------------------------------------------------------
*/
int
Tcl_DisassembleObjCmd(
void *clientData, /* What type of operation. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const types[] = {
"constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. */ #include "tclInt.h" #include <assert.h> typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to |
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
static const Tcl_ObjType encodingType = {
"encoding",
FreeEncodingInternalRep,
DupEncodingInternalRep,
NULL,
NULL,
| < > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
static const Tcl_ObjType encodingType = {
"encoding",
FreeEncodingInternalRep,
DupEncodingInternalRep,
NULL,
NULL,
0
};
#define EncodingSetInternalRep(objPtr, encoding) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (encoding); \
ir.twoPtrValue.ptr2 = NULL; \
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
const char *src, /* Source string in specified encoding. */
Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
| | | | | | | | | 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 |
const char *src, /* Source string in specified encoding. */
Tcl_Size srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_ExternalToUtfDStringEx --
*
* Convert a source buffer from the specified encoding into UTF-8.
* "flags" controls the behavior if any of the bytes in
* the source buffer are invalid or cannot be represented in utf-8.
* Possible flags values:
* target encoding. It should be composed by OR-ing the following:
* - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT}
*
* Results:
* The return value is one of:
* TCL_OK: success. Converted string in *dstPtr.
* TCL_ERROR: Error in passed parameters. Error message in interp.
* TCL_CONVERT_MULTIBYTE: Source ends in truncated multibyte sequence.
* TCL_CONVERT_SYNTAX: Source is not conformant to encoding definition.
* TCL_CONVERT_UNKNOWN: Source contained a character that could not.
* be represented in target encoding.
*
* Side effects:
* TCL_OK: The converted bytes are stored in the DString and NUL
* terminated in an encoding-specific manner.
* TCL_ERROR: an error, message is stored in the interp if not NULL.
* TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 |
OUTPUT_ISOLATEDSURROGATE; \
continue; /* Rerun loop so length checks etc. repeated */ \
} else \
(void) 0
profile = ENCODING_PROFILE_GET(flags);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
| < | 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 |
OUTPUT_ISOLATEDSURROGATE; \
continue; /* Rerun loop so length checks etc. repeated */ \
} else \
(void) 0
profile = ENCODING_PROFILE_GET(flags);
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
|
| ︙ | ︙ | |||
2559 2560 2561 2562 2563 2564 2565 |
*/
*dst++ = 0;
src += 2;
}
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
| | | | | | | > | 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 |
*/
*dst++ = 0;
src += 2;
}
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Incomplete byte sequence not because there are insufficient
* bytes in source buffer (have already checked that above) but
* because the UTF-8 sequence is truncated.
*/
CHECK_ISOLATEDSURROGATE;
if (flags & ENCODING_INPUT) {
/* Incomplete bytes for modified UTF-8 target */
if (PROFILE_STRICT(profile)) {
result = (flags & TCL_ENCODING_CHAR_LIMIT)
? TCL_CONVERT_MULTIBYTE
: TCL_CONVERT_SYNTAX;
break;
}
}
if (PROFILE_REPLACE(profile)) {
ch = UNICODE_REPLACE_CHAR;
++src;
} else {
/* TCL_ENCODING_PROFILE_TCL8 */
char chbuf[2];
chbuf[0] = UCHAR(*src++);
chbuf[1] = 0;
TclUtfToUniChar(chbuf, &ch);
}
dst += Tcl_UniCharToUtf(ch, dst);
} else {
/* Have a complete character */
size_t len = TclUtfToUniChar(src, &ch);
|
| ︙ | ︙ | |||
3506 3507 3508 3509 3510 3511 3512 |
if (prefixBytes[byte]) {
src--;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
} else {
char chbuf[2];
| | > | 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 |
if (prefixBytes[byte]) {
src--;
}
if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
} else {
char chbuf[2];
chbuf[0] = byte;
chbuf[1] = 0;
TclUtfToUniChar(chbuf, &ch);
}
}
/*
* Special case for 1-byte Utf chars for speed.
*/
|
| ︙ | ︙ | |||
3804 3805 3806 3807 3808 3809 3810 |
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
/*
* Plunge on, using '?' as a fallback character.
*/
| < | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 |
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_UNKNOWN;
break;
}
/*
* Plunge on, using '?' as a fallback character.
*/
ch = '?'; /* Profiles TCL8 and REPLACE */
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
|
| ︙ | ︙ | |||
4487 4488 4489 4490 4491 4492 4493 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
| | | 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
*valuePtr = (char *)Tcl_Alloc(numBytes + 1);
memcpy(*valuePtr, bytes, numBytes + 1);
Tcl_DecrRefCount(searchPathObj);
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2005-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclEnsemble.c -- * * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. */ #include "tclInt.h" #include "tclCompile.h" /* * Declarations for functions local to this file: */ |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
static const Tcl_ObjType ensembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
| < > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
static const Tcl_ObjType ensembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
#define ECRSetInternalRep(objPtr, ecRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (ecRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 | const char *subcmdName; /* Name of the subcommand or unique prefix of * it (a non-unique prefix produces an error). */ char *fullName = NULL; /* Full name of the subcommand. */ Tcl_Size stringLength, i; Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; | | | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
const char *subcmdName; /* Name of the subcommand or unique prefix of
* it (a non-unique prefix produces an error). */
char *fullName = NULL; /* Full name of the subcommand. */
Tcl_Size stringLength, i;
Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
stringLength);
if (cmp == 0) {
if (fullName != NULL) {
|
| ︙ | ︙ | |||
1938 1939 1940 1941 1942 1943 1944 |
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
TclListObjLength(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
| | > > > > | 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 |
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
TclListObjLength(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclDuplicatePureObj(
interp, prefixObj, tclListTypePtr);
if (!copyPtr) {
return TCL_ERROR;
}
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
ensemblePtr->numParameters, objv + 1);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
objc - 2 - ensemblePtr->numParameters,
|
| ︙ | ︙ | |||
2352 2353 2354 2355 2356 2357 2358 |
Tcl_Size i, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
| > | > > > | 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 |
Tcl_Size i, prefixObjc;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = TclDuplicatePureObj(
interp, ensemblePtr->unknownHandler, tclListTypePtr);
if (!unknownCmd) {
return TCL_ERROR;
}
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
for (i = 1 ; i < objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv);
|
| ︙ | ︙ | |||
2712 2713 2714 2715 2716 2717 2718 | Tcl_IncrRefCount(target); continue; } } /* * Target was not in the dictionary. Map onto the namespace. | | | | | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 | Tcl_IncrRefCount(target); continue; } } /* * Target was not in the dictionary. Map onto the namespace. * In this case there is no guarantee that the command * is actually there. It is the responsibility of the * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } |
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
const char *str;
Tcl_Obj *matchObj = NULL;
if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto tryCompileToInv;
}
for (i=0 ; i<len ; i++) {
| | | | 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 |
const char *str;
Tcl_Obj *matchObj = NULL;
if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto tryCompileToInv;
}
for (i=0 ; i<len ; i++) {
str = Tcl_GetStringFromObj(elems[i], &sclen);
if ((sclen == numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
*/
result = Tcl_DictObjGet(NULL, mapObj, elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto tryCompileToInv;
}
replacement = elems[i];
goto doneMapLookup;
}
|
| ︙ | ︙ | |||
3467 3468 3469 3470 3471 3472 3473 |
* difference. Hence the call to TclContinuationsEnterDerived...
*/
TclListObjGetElements(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i <= numWords) {
| | | 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 |
* difference. Hence the call to TclContinuationsEnterDerived...
*/
TclListObjGetElements(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i <= numWords) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterLiteral(envPtr,
|
| ︙ | ︙ | |||
3496 3497 3498 3499 3500 3501 3502 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
| | | < | 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 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
* Do the replacing dispatch.
*/
TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords, numWords+1);
}
/*
* 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
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclEnv.c -- * * Tcl support for environment variables, including a setenv function. * This file contains the generic portion of the environment module. It * is primarily responsible for keeping the "env" arrays in sync with the * system environment variables. | > > > > > > > > > > > > > > > > > < < < < < < | > | > | > | | | | 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 |
/*
* Copyright © 1991-1994 The Regents of the University of California.
* Copyright © 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclEnv.c --
*
* Tcl support for environment variables, including a setenv function.
* This file contains the generic portion of the environment module. It
* is primarily responsible for keeping the "env" arrays in sync with the
* system environment variables.
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
# define tenviron2utfdstr(str, dsPtr) \
(Tcl_DStringInit(dsPtr), \
(char *)Tcl_Char16ToUtfDString( \
(const unsigned short *)(str), -1, (dsPtr)))
# define utf2tenvirondstr(str, dsPtr) \
(Tcl_DStringInit(dsPtr), \
(const WCHAR *) Tcl_UtfToChar16DString((str), -1, (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
# endif
#else
# define tenviron environ
# define tenviron2utfdstr(str, dsPtr) \
Tcl_ExternalToUtfDString(NULL, str, -1, dsPtr)
# define utf2tenvirondstr(str, dsPtr) \
Tcl_UtfToExternalDString(NULL, str, -1, dsPtr)
# define techar char
#endif
/* MODULE_SCOPE */
size_t TclEnvEpoch = 0; /* Epoch of the tcl environment
* (if changed with tcl-env). */
static struct {
Tcl_Size cacheSize; /* Number of env strings in cache. */
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
techar **ourEnviron; /* Cache of the array that we allocate. We
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
Tcl_Size ourEnvironSize; /* Non-zero means that the environ array was
* malloced and has this many total entries
* allocated to it (not all may be in use at
* once). Zero means that the environment
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1990-1994 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2004 Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" command * functions. */ #include "tclInt.h" #include "tclUuid.h" #if defined(HAVE_ZLIB) && defined(TCL_WITH_INTERNAL_ZLIB) #include "zlib.h" #endif /* HAVE_ZLIB */ /* |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
| | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
void *clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers. The first list is
* controlled by a mutex. The other is in thread local storage.
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
void *clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(void *clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors( | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
* Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(
void *clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
/*
* Not bothering to save/restore the interp state. Assume that any code
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | Tcl_Obj **prefixObjv, **tempObjv; /* * Note we copy the handler command prefix each pass through, so we do * support one handler setting another handler. */ | | > > > > | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
Tcl_Obj **prefixObjv, **tempObjv;
/*
* Note we copy the handler command prefix each pass through, so we do
* support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclDuplicatePureObj(
interp, assocPtr->cmdPrefix, tclListTypePtr);
if (!copyObj) {
return;
}
errPtr = assocPtr->firstBgPtr;
TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | * reports, they are canceled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
* reports, they are canceled.
*
*----------------------------------------------------------------------
*/
static void
BgErrorDeleteProc(
void *clientData, /* Pointer to ErrAssocData structure. */
TCL_UNUSED(Tcl_Interp *))
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
|
| ︙ | ︙ | |||
701 702 703 704 705 706 707 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 | } /* *---------------------------------------------------------------------- * * InvokeExitHandlers -- * | | | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 |
}
/*
*----------------------------------------------------------------------
*
* InvokeExitHandlers --
*
* Call the registered exit handlers.
*
* Results:
* None.
*
* Side effects:
* The exit handlers are invoked, and the Exi tHandler struct is
* freed.
*
*----------------------------------------------------------------------
*/
static void
InvokeExitHandlers(void)
{
ExitHandler *exitPtr;
|
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 | #endif #if defined(_MSC_VER) ".msvc-" STRINGIFY(_MSC_VER) #endif #ifdef USE_NMAKE ".nmake" #endif | < < < | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 | #endif #if defined(_MSC_VER) ".msvc-" STRINGIFY(_MSC_VER) #endif #ifdef USE_NMAKE ".nmake" #endif #if !TCL_THREADS ".no-thread" #endif #ifndef TCL_CFG_OPTIMIZED ".no-optimize" #endif #ifdef __OBJC__ |
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
/*
* Double check inside the mutex. There are definitely calls back into
* this routine from some of the functions below.
*/
TclpInitLock();
if (subsystemsInitialized == 0) {
| < | | > > > > > | 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 |
/*
* Double check inside the mutex. There are definitely calls back into
* this routine from some of the functions below.
*/
TclpInitLock();
if (subsystemsInitialized == 0) {
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
*/
TclInitThreadStorage(); /* Creates hash table for
* thread local storage */
#if defined(USE_TCLALLOC) && USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
TclInitThreadAlloc(); /* Setup thread allocator caches */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
TclArithSeriesInit();
TclListInit();
TclDictInit();
TclProcInit();
subsystemsInitialized = 1;
}
TclpInitUnlock();
}
TclInitNotifier();
return stubInfo.version;
}
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 |
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
| | | 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 |
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
size_t stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData));
int result;
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2002-2010 Miguel Sofer. * Copyright © 2005-2007 Donal K. Fellows. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * Copyright © 2021-2024 Nathan Coulter. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl commands. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> |
| ︙ | ︙ | |||
448 449 450 451 452 453 454 | * Tcl_GetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * void **ptrPtr, int *tPtr); */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 |
* Tcl_GetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* void **ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasInternalRep((objPtr), tclDoubleTypePtr) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
const Tcl_ObjType tclExprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
| < > < > | 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 |
const Tcl_ObjType tclExprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
* Custom object type only used in this file; values of its type should never
* be seen by user scripts.
*/
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
ReleaseDictIterator,
NULL, NULL, NULL,
0
};
/*
*----------------------------------------------------------------------
*
* ReleaseDictIterator --
*
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
{
Tcl_MutexLock(&execMutex);
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
}
/*
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
{
Tcl_MutexLock(&execMutex);
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
}
/*
* Auxiliary code to ensure that GrowEvaluationStack returns correctly
* aligned memory.
*
* WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN
* represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a
* multiple of the wordsize 'sizeof(Tcl_Obj *)'.
*/
|
| ︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 |
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
Tcl_Size length;
| | | 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
Tcl_Size length;
const char *string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
* push an zero object as the expression's result.
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 | /* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression | | | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | /* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression * bytecode. We do not copy the bytecode intrep. Instead, we return * without setting copyPtr->typePtr, so the copy is a plain string copy * of the expression value, and if it is to be used as a compiled * expression, it will just need a recompile. * * This makes sense, because with Tcl's copy-on-write practices, the * usual (only?) time Tcl_DuplicateObj() will be called is when the copy * is about to be modified, which would invalidate any copied bytecode * anyway. The only reason it might make sense to copy the bytecode is if * we had some modifying routines that operated directly on the intrep, * like we do for lists and dicts. * * Results: * None. * * Side effects: * None. |
| ︙ | ︙ | |||
3370 3371 3372 3373 3374 3375 3376 |
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
| | > > > > > > > > > | 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 |
lappendListDirect:
objResultPtr = varPtr->value.objPtr;
if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue;
DECACHE_STACK_INFO();
newValue = TclDuplicatePureObj(interp, objResultPtr, tclListTypePtr);
CACHE_STACK_INFO();
if (!newValue) {
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
|
| ︙ | ︙ | |||
3429 3430 3431 3432 3433 3434 3435 |
if (!objResultPtr) {
valueToAssign = valuePtr;
} else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
| > | > > > > > | 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 |
if (!objResultPtr) {
valueToAssign = valuePtr;
} else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
DECACHE_STACK_INFO();
valueToAssign = TclDuplicatePureObj(
interp, objResultPtr, tclListTypePtr);
CACHE_STACK_INFO();
if (!valueToAssign) {
goto errorInLappendListPtr;
}
createdNewObj = 1;
} else {
valueToAssign = objResultPtr;
}
if (TclListObjAppendElements(interp, valueToAssign,
objc, objv) != TCL_OK) {
if (createdNewObj) {
|
| ︙ | ︙ | |||
4389 4390 4391 4392 4393 4394 4395 |
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(objResultPtr);
Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
| > | > > | | | | | | | | | | > | 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 |
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(objResultPtr);
Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
{
int isEmpty = TCL_EMPTYSTRING_YES, status;
status = TclCheckEmptyString(interp, objResultPtr, &isEmpty);
if (status || isEmpty == TCL_EMPTYSTRING_YES) {
Tcl_DecrRefCount(objResultPtr);
instOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
TclGetString(OBJ_AT_TOS), (char *)NULL);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: not command\n"));
goto gotError;
}
}
TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
NEXT_INST_F(1, 1, 1);
}
/*
* -----------------------------------------------------------------
|
| ︙ | ︙ | |||
4683 4684 4685 4686 4687 4688 4689 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
| | > | 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
int dstatus, numIndices, nocase, match, cflags,
toIdxAnchor, fromIdxAnchor;
Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj and then
* decrement their ref counts.
|
| ︙ | ︙ | |||
4712 4713 4714 4715 4716 4717 4718 |
TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
| > > > > > > > > > > > > | > > > > | > | > | | > > > > > | > | | | | | > > > > > > > > | > > > > > > > > > > > > > > > > > > | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 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 |
TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (
TclHasInternalRep(value2Ptr, tclListTypePtr)
||
TclObjectHasInterface(value2Ptr, list, length)
) {
Tcl_Size value2Length;
if (Tcl_ListObjLength(interp,value2Ptr,&value2Length),
value2Length == 1) {
if (TclHasInternalRep(value2Ptr, tclListTypePtr)) {
value2Ptr = TclListObjGetElement(value2Ptr, 0);
} else {
Tcl_ListObjIndex(interp, value2Ptr, 0, &value2Ptr);
}
} else {
goto TclLindexList;
}
}
if (TclObjectHasInterface(valuePtr, list, length)
|| TclHasInternalRep(valuePtr, tclListTypePtr)) {
int code, haveElements = 0, status;
if (TclHasInternalRep(valuePtr, tclListTypePtr)) {
/* since the type is tclListTypePtr, this can't fail */
TclListObjGetElements(interp, valuePtr, &objc, &objv);
haveElements = 1;
} else {
TclObjectDispatchNoDefault(interp, status, valuePtr, list,
length, interp, valuePtr, &objc);
if (status != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (objc < 0) {
objc = TCL_SIZE_MAX;
}
}
Tcl_IncrRefCount(value2Ptr);
DECACHE_STACK_INFO();
code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index);
CACHE_STACK_INFO();
if (code != TCL_OK) {
goto TclLindexList;
}
Tcl_DecrRefCount(value2Ptr);
if (haveElements && code == TCL_OK) {
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
}
Tcl_ResetResult(interp);
TclObjectDispatchNoDefault(interp, status, valuePtr, list,
index, interp, valuePtr, index, &objResultPtr);
if (status != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (objResultPtr == NULL) {
TclNewObj(objResultPtr);
}
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
/* Index is out of range, return empty result. */
TclNewObj(objResultPtr);
}
Tcl_IncrRefCount(objResultPtr); // reference held here
goto lindexDone;
}
TclLindexList:
/*
* Extract the desired list element.
*/
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
CACHE_STACK_INFO();
lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
|
| ︙ | ︙ | |||
4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 |
/*
* Pop the list and get the index.
*/
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > | < < > | | < | | < > | > > > > > > | < < > | > > > > > > | | | | | < | | | > | 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 |
/*
* Pop the list and get the index.
*/
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
if (TclObjectHasInterface(valuePtr, list, length)
&& TclObjectHasInterface(valuePtr ,list ,index)) {
TCL_UNUSEDVAR(int status);
TclObjectDispatchNoDefault(interp, status, valuePtr, list,
length, interp, valuePtr, &length);
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, length-1);
/* Compute value @ index */
if (index >= 0 && index < length) {
TclObjectDispatchNoDefault(interp, status, valuePtr, list,
index, interp, valuePtr, index, &objResultPtr);
if (objResultPtr == NULL) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
} else {
TclNewObj(objResultPtr);
}
pcAdjustment = 5;
goto lindexFastPath2;
}
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
if (!TclHasInternalRep(valuePtr, tclListTypePtr)
&& TclObjectHasInterface(valuePtr, list, index)) {
if (Tcl_ListObjLength(interp, valuePtr, &objc) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (TclIndexIsFromEnd(opnd) && !Tcl_LengthIsFinite(objc)) {
/* end-relative index, and list end is indeterminate */
if (TclObjectDispatchNoDefault(interp, dstatus, valuePtr, list, indexEnd,
interp, valuePtr, index, &objResultPtr) != TCL_OK
|| dstatus != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
index = TclIndexDecode(opnd, TclIndexLast(objc));
if (Tcl_ListObjIndex(interp, valuePtr, index, &objResultPtr)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
}
if (objResultPtr == NULL) {
TclNewObj(objResultPtr);
}
Tcl_IncrRefCount(objResultPtr);
/*
* Stash the list element on the stack.
*/
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
/* Already has the correct refCount */
NEXT_INST_F(5, 1, -1);
} else {
if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, TclIndexLast(objc));
pcAdjustment = 5;
}
lindexFastPath:
if (index >= 0 && index < objc) {
objResultPtr = objv[index];
} else {
TclNewObj(objResultPtr);
}
|
| ︙ | ︙ | |||
4902 4903 4904 4905 4906 4907 4908 | Tcl_DecrRefCount(valuePtr); /* This one should be done here */ /* * Compute the new variable value. */ DECACHE_STACK_INFO(); | < > | < < < | | | | | | | > | | 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 |
Tcl_DecrRefCount(valuePtr); /* This one should be done here */
/*
* Compute the new variable value.
*/
DECACHE_STACK_INFO();
{
int status;
status = TclLsetFlat(interp, valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS, &objResultPtr);
if (status != TCL_OK || !objResultPtr) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
}
/*
* Set result.
*/
CACHE_STACK_INFO();
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(5, numIndices+1, 1);
case INST_LSET_LIST: /* 'lset' with 4 args */
/*
* Get the old value of variable, and remove the stack ref. This is
* safe because the variable still references the object; the ref
* count will never go zero here - we can use the smaller macro
* Tcl_DecrRefCount.
|
| ︙ | ︙ | |||
4958 4959 4960 4961 4962 4963 4964 |
}
/*
* Set result.
*/
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
| | | 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 |
}
/*
* Set result.
*/
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
* bytecode stream */
/*
* Pop the list and get the indices.
*/
|
| ︙ | ︙ | |||
5012 5013 5014 5015 5016 5017 5018 |
if (toIdx == TCL_INDEX_NONE) {
emptyList:
TclNewObj(objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
}
| < < < < < | | < < | | < < > | | | | | | > > > | < | < > > > > > | | | > > > > > > > | > | > | > > | | | > > | | | | | < < | | > | < > < | < < | < | 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 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 |
if (toIdx == TCL_INDEX_NONE) {
emptyList:
TclNewObj(objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
}
toIdxAnchor = TclIndexIsFromEnd(toIdx);
fromIdxAnchor = TclIndexIsFromEnd(fromIdx);
DECACHE_STACK_INFO();
if (!Tcl_LengthIsFinite(objc)
&& (toIdxAnchor == 1 || fromIdxAnchor == 1)) {
toIdx = TclIndexDecode(toIdx, SIZE_MAX);
fromIdx = TclIndexDecode(fromIdx, SIZE_MAX);
dstatus = TclObjectInterfaceCall(valuePtr, list, rangeEnd,
interp, valuePtr, toIdxAnchor, toIdx, fromIdxAnchor,
fromIdx, &objResultPtr);
if (dstatus != TCL_OK || objResultPtr == NULL) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
} else {
toIdx = TclIndexDecode(toIdx, TclIndexLast(objc));
if (toIdx == TCL_INDEX_NONE) {
goto emptyList;
} else if (Tcl_LengthIsFinite(objc) && toIdx + 1 >= objc + 1) {
toIdx = TclIndexLast(objc);
}
assert (toIdx < objc);
/*
assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, objc - 1);
/* to do: catch status? */
TclListObjRange(interp, valuePtr, fromIdx, toIdx, &objResultPtr);
}
CACHE_STACK_INFO();
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclObjectHasInterface(value2Ptr, list, contains)) {
int status;
TclObjectDispatchNoDefault(interp, status, value2Ptr, list,
contains, interp, value2Ptr, valuePtr, &match);
if (status != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
match = 0;
if (length > 0) {
Tcl_Size i = 0;
Tcl_Obj *o;
/*
* An empty list doesn't match anything.
*/
do {
if (TclObjectHasInterface(valuePtr, list, index)) {
TCL_UNUSEDVAR(int status);
TclObjectDispatchNoDefault(interp, status, value2Ptr, list,
index, interp, value2Ptr, i, &o);
if (!o) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
}
if (o != NULL) {
s2 = Tcl_GetStringFromObj(o, &s2len);
} else {
s2 = "";
s2len = 0;
}
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
TclBounceRefCount(o);
i++;
} while (i < length && match == 0);
}
}
if (*pc == INST_LIST_NOT_IN) {
match = !match;
|
| ︙ | ︙ | |||
5178 5179 5180 5181 5182 5183 5184 |
if (TclGetIntForIndexM(interp, fromIdxObj, length - end_indicator,
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
| | | | 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 |
if (TclGetIntForIndexM(interp, fromIdxObj, length - end_indicator,
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (fromIdx < 0) {
fromIdx = 0;
} else if (fromIdx > length) {
fromIdx = length;
}
numToDelete = 0;
if (toIdxObj) {
if (TclGetIntForIndexM(interp, toIdxObj, length - end_indicator,
&toIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (toIdx != TCL_INDEX_NONE) {
if (toIdx > length) {
toIdx = length;
}
if (toIdx >= fromIdx) {
numToDelete = toIdx - fromIdx + 1;
}
}
}
CACHE_STACK_INFO();
if (Tcl_IsShared(valuePtr)) {
|
| ︙ | ︙ | |||
5300 5301 5302 5303 5304 5305 5306 |
TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
| | | | | 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 |
TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = Tcl_GetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToUpper(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, slength);
TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_LOWER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = Tcl_GetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToLower(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, slength);
TclFreeInternalRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_TITLE:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = Tcl_GetStringFromObj(valuePtr, &slength);
TclNewStringObj(objResultPtr, s1, slength);
slength = Tcl_UtfToTitle(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, slength);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
slength = Tcl_UtfToTitle(TclGetString(valuePtr));
|
| ︙ | ︙ | |||
5358 5359 5360 5361 5362 5363 5364 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calculate what 'end' means.
*/
slength = Tcl_GetCharLength(valuePtr);
| > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 |
TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calculate what 'end' means.
*/
slength = Tcl_GetCharLength(valuePtr);
if (TclObjectHasInterface(valuePtr, string, index)) {
int status;
status = TclStringIndexInterface(interp, valuePtr, value2Ptr, &objResultPtr);
if (status != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
DECACHE_STACK_INFO();
if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
if (index < 0 || index >= slength) {
TclNewObj(objResultPtr);
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetBytesFromObj(NULL, valuePtr, NULL)+index, 1);
} else if (valuePtr->bytes && slength == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
char buf[4] = "";
int ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be faster in
* practical use.
*/
if (ch == -1) {
TclNewObj(objResultPtr);
} else {
slength = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, slength);
}
}
}
TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
|
| ︙ | ︙ | |||
5433 5434 5435 5436 5437 5438 5439 |
/* Every range of an empty value is an empty value */
if (slength == 0) {
TRACE_APPEND(("\n"));
NEXT_INST_F(9, 0, 0);
}
| > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > > > > > > > > > > > > > > > > > | | > > > > > | > > > | > | > | 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 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 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 |
/* Every range of an empty value is an empty value */
if (slength == 0) {
TRACE_APPEND(("\n"));
NEXT_INST_F(9, 0, 0);
}
if (TclObjectHasInterface(valuePtr, list, index)) {
if ((TclIndexIsFromEnd(toIdx) || TclIndexIsFromEnd(fromIdx))
&& !Tcl_LengthIsFinite(slength)) {
fromIdx = TclIndexDecode(fromIdx, TclIndexLast(slength));
toIdx = TclIndexDecode(toIdx, TclIndexLast(slength));
if (TclObjectInterfaceCall(valuePtr,
string, rangeEnd, valuePtr, fromIdx, toIdx, &objResultPtr)
!= TCL_OK || objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
fromIdx = TclIndexDecode(fromIdx, TclIndexLast(slength));
toIdx = TclIndexDecode(toIdx, TclIndexLast(slength));
if (TclObjectInterfaceCall(valuePtr, string, range, valuePtr,
fromIdx, toIdx, &objResultPtr)
!= TCL_OK || objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
}
} else {
/* Decode index operands. */
/*
assert ( toIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (toIdx == TCL_INDEX_NONE) {
goto emptyRange;
}
toIdx = TclIndexDecode(toIdx, slength - 1);
if (toIdx == TCL_INDEX_NONE) {
goto emptyRange;
} else if (toIdx >= slength) {
toIdx = slength - 1;
}
assert ( toIdx != TCL_INDEX_NONE && toIdx < slength );
/*
assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, slength - 1);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
if (fromIdx + 1 <= toIdx + 1) {
objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
} else {
emptyRange:
TclNewObj(objResultPtr);
}
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
{
Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
Tcl_Size length3;
|
| ︙ | ︙ | |||
5653 5654 5655 5656 5657 5658 5659 |
{
const char *string1, *string2;
Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
| | | | | | | | 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 |
{
const char *string1, *string2;
Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = Tcl_GetStringFromObj(value2Ptr, &length2);
string1 = Tcl_GetStringFromObj(valuePtr, &slength);
trim1 = TclTrimLeft(string1, slength, string2, length2);
trim2 = 0;
goto createTrimmedString;
case INST_STR_TRIM_RIGHT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = Tcl_GetStringFromObj(value2Ptr, &length2);
string1 = Tcl_GetStringFromObj(valuePtr, &slength);
trim2 = TclTrimRight(string1, slength, string2, length2);
trim1 = 0;
goto createTrimmedString;
case INST_STR_TRIM:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = Tcl_GetStringFromObj(value2Ptr, &length2);
string1 = Tcl_GetStringFromObj(valuePtr, &slength);
trim1 = TclTrim(string1, slength, string2, length2, &trim2);
createTrimmedString:
/*
* Careful here; trim set often contains non-ASCII characters so we
* take care when printing. [Bug 971cb4f1db]
*/
|
| ︙ | ︙ | |||
5765 5766 5767 5768 5769 5770 5771 |
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE: {
| | | > > > > > > > > > > > > | 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 |
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE: {
int isEmpty, iResult = 0, compare = 0, status;
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/*
Try to determine, without triggering generation of a string
representation, whether one value is not a number.
*/
status = TclCheckEmptyString(interp, valuePtr, &isEmpty);
if (status) {
goto gotError;
}
if (isEmpty > 0) {
goto stringCompare;
} else {
status = TclCheckEmptyString(interp, value2Ptr ,&isEmpty);
if (status) {
goto gotError;
}
if (isEmpty > 0) {
goto stringCompare;
}
}
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
|| GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
/*
* At least one non-numeric argument - compare as strings.
*/
|
| ︙ | ︙ | |||
6397 6398 6399 6400 6401 6402 6403 |
if (valuePtr->bytes == NULL) {
TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
if (Tcl_IsShared(valuePtr)) {
/*
* Here we do some surgery within the Tcl_Obj internals. We want
| | | 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 |
if (valuePtr->bytes == NULL) {
TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
if (Tcl_IsShared(valuePtr)) {
/*
* Here we do some surgery within the Tcl_Obj internals. We want
* to copy the intrep, but not the string, so we temporarily hide
* the string so we do not copy it.
*/
char *savedString = valuePtr->bytes;
valuePtr->bytes = NULL;
objResultPtr = Tcl_DuplicateObj(valuePtr);
|
| ︙ | ︙ | |||
6422 6423 6424 6425 6426 6427 6428 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
| | | 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasInternalRep(valuePtr, tclBooleanTypePtr)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(res);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
|
| ︙ | ︙ | |||
6491 6492 6493 6494 6495 6496 6497 |
if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
| > | > > > > > | 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 |
if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
DECACHE_STACK_INFO();
objPtr = TclDuplicatePureObj(
interp, listPtr, tclListTypePtr);
CACHE_STACK_INFO();
if (!objPtr) {
goto gotError;
}
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(listPtr);
OBJ_AT_DEPTH(listTmpDepth) = objPtr;
}
iterTmp = (listLen + (numVars - 1))/numVars;
if (iterTmp > iterMax) {
iterMax = iterTmp;
|
| ︙ | ︙ | |||
6565 6566 6567 6568 6569 6570 6571 |
tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
| < < | < < | 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 |
tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
DECACHE_STACK_INFO();
if (TclObjectHasInterface(listPtr, list, index)) {
status = Tcl_ListObjLength(interp, listPtr, &listLen);
elements = NULL;
} else {
status = TclListObjGetElements(
interp, listPtr, &listLen, &elements);
}
if (status != TCL_OK) {
CACHE_STACK_INFO();
goto gotError;
}
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
DECACHE_STACK_INFO();
if (elements) {
|
| ︙ | ︙ | |||
7126 7127 7128 7129 7130 7131 7132 |
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
/*
* dictPtr is no longer on the stack, and we're not
| | | 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 |
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
/*
* dictPtr is no longer on the stack, and we're not
* moving it into the intrep of an iterator. We need
* to drop the refcount [Tcl Bug 9b352768e6].
*/
Tcl_DecrRefCount(dictPtr);
Tcl_Free(searchPtr);
TRACE_ERROR(interp);
goto gotError;
|
| ︙ | ︙ | |||
7739 7740 7741 7742 7743 7744 7745 |
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
/*
| | | | | 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 |
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
/*
* INST_START_CMD failure case removed where it doesn't bother that much.
*
* If the interpreter is marked for deletion, its
* compileEpoch is modified, Therefore 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:
|
| ︙ | ︙ | |||
8475 8476 8477 8478 8479 8480 8481 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
| | | 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
|| !TclHasInternalRep(value2Ptr, tclIntTypePtr)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
err = mp_init(&bigResult);
|
| ︙ | ︙ | |||
9106 9107 9108 9109 9110 9111 9112 |
op = "**";
} else if (opcode <= INST_LNOT) {
op = operatorStrings[opcode - INST_BITOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
Tcl_Size length;
| | > > | | | | > > | 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 |
op = "**";
} else if (opcode <= INST_LNOT) {
op = operatorStrings[opcode - INST_BITOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
Tcl_Size length;
if (TclHasInternalRep(opndPtr, tclDictTypePtr)) {
Tcl_DictObjSize(NULL, opndPtr, &length);
if (length > 1) {
listRep:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot use a list as %soperand of \"%s\"", ord, op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "list", (char *)NULL);
return;
}
}
if (TclObjectHasInterface(opndPtr ,list ,length)) {
int status;
status = Tcl_ListObjLength(interp,opndPtr,&length);
if (!status && length > 1) {
goto listRep;
}
}
description = "non-numeric string";
} else if (type == TCL_NUMBER_NAN) {
description = "non-numeric floating-point value";
} else if (type == TCL_NUMBER_DOUBLE) {
description = "floating-point value";
} else {
/* TODO: No caller needs this. Eliminate? */
|
| ︙ | ︙ | |||
9744 9745 9746 9747 9748 9749 9750 |
strBytesSharedOnce = 0.0;
for (ui = 0; ui < globalTablePtr->numBuckets; ui++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
| | | 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 |
strBytesSharedOnce = 0.0;
for (ui = 0; ui < globalTablePtr->numBuckets; ui++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
|
| ︙ | ︙ | |||
9970 9971 9972 9973 9974 9975 9976 |
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
| | | 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 10158 10159 10160 10161 |
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
char *str = Tcl_GetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {
outChan = Tcl_GetStdChannel(TCL_STDOUT);
} else if (strcmp(str, "stderr") == 0) {
outChan = Tcl_GetStdChannel(TCL_STDERR);
} else {
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. */ #include "tclInt.h" #include "tclFileSystem.h" /* * Declarations for local functions defined in this file: */ |
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 |
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[2];
| | | 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 |
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[2];
const char *string = Tcl_GetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
goto makeTemporary;
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
}
/*
* Create and open the temporary file.
*/
makeTemporary:
| | | 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 |
}
/*
* Create and open the temporary file.
*/
makeTemporary:
chan = TclpOpenTemporaryFile(tempDirObj, tempBaseObj, tempExtObj, nameObj);
/*
* If we created pieces of template, get rid of them now.
*/
if (tempDirObj) {
TclDecrRefCount(tempDirObj);
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
| | | 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 |
Tcl_WrongNumArgs(interp, 1, objv, "?template?");
return TCL_ERROR;
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
const char *string = Tcl_GetStringFromObj(templateObj, &length);
const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1998 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclFileName.c -- * * This file contains routines for converting file names betwen native * and network form. */ #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. |
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
*/
Tcl_PathType
Tcl_GetPathType(
const char *path)
{
Tcl_PathType type;
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
*/
Tcl_PathType
Tcl_GetPathType(
const char *path)
{
Tcl_PathType type;
Tcl_Obj *tempObj = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(tempObj);
type = Tcl_FSGetPathType(tempObj);
Tcl_DecrRefCount(tempObj);
return type;
}
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
| | > | | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
Tcl_Size *driveNameLengthPtr,
/* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
const char *path = TclGetString(pathPtr);
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
| | | | 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 |
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
(void)Tcl_GetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
* plus the argv pointers and the terminating NULL pointer.
*/
*argvPtr = (const char **)Tcl_Alloc(
((((*argcPtr) + 1) * sizeof(char *)) + size));
/*
* Position p after the last argv pointer and copy the contents of the
* list in, piece by piece.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
str = Tcl_GetStringFromObj(eltPtr, &len);
memcpy(p, str, len + 1);
p += len+1;
}
/*
* Now set up the argv pointers.
*/
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 |
{
int needsSep;
Tcl_Size length;
char *dest;
const char *p;
const char *start;
| | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
{
int needsSep;
Tcl_Size length;
char *dest;
const char *p;
const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
/*
* Remove the ./ from drive-letter prefixed
* elements on Windows, unless it is the first component.
*/
p = joining;
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
| | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 |
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
| | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 |
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
(void)Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
Tcl_IncrRefCount(resultObj);
Tcl_DecrRefCount(listObj);
/*
* Store the result.
*/
| | | | | 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 |
Tcl_IncrRefCount(resultObj);
Tcl_DecrRefCount(listObj);
/*
* Store the result.
*/
resultStr = Tcl_GetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
/*
* Return a pointer to the result.
*/
return Tcl_DStringValue(resultPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_TranslateFileName --
*
* Converts a file name into a form usable by the native system
* interfaces.
*
* Results:
* The return value is a pointer to a string containing the name.
* This may either be the name pointer passed in or space allocated in
* bufferPtr. In all cases, if the return value is not NULL, the caller
* must call Tcl_DStringFree() to free the space. If there was an
* error in processing the name, then an error message is left in the
* interp's result (if interp was not NULL) and the return value is NULL.
*
* Side effects:
* None.
*
|
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 |
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
enum globOptionsEnum {
GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
GLOB_TYPE, GLOB_LAST
} index;
| | | 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 |
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
enum globOptionsEnum {
GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
GLOB_TYPE, GLOB_LAST
} index;
enum pathDirOptions {PATH_NONE = -1, PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 | globFlags |= TCL_GLOBMODE_DIR; pathOrDir = objv[i+1]; i++; break; case GLOB_JOIN: /* -join */ join = 1; break; | | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
globFlags |= TCL_GLOBMODE_DIR;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
case GLOB_TAILS: /* -tails */
globFlags |= TCL_GLOBMODE_TAILS;
break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL);
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
Tcl_Size pathlength;
const char *last;
| | | 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
Tcl_Size pathlength;
const char *last;
const char *first = Tcl_GetStringFromObj(pathOrDir ,&pathlength);
/*
* Find the last path separator in the path
*/
last = first + pathlength;
for (; last != first; last--) {
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
globTypes->macCreator = NULL;
while (length-- > 0) {
Tcl_Size len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
| | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
globTypes->macCreator = NULL;
while (length-- > 0) {
Tcl_Size len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
} else if (len == 1) {
switch (str[0]) {
case 'r':
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 |
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
| | | | 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 |
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
if (prefixLen > 0
&& (strchr(separators, pre[prefixLen-1]) == NULL)) {
/*
* If we're on Windows and the prefix is a volume relative one
* like 'C:', then there won't be a path separator in between, so
* no need to skip it here.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)
|| (pre[1] != ':')) {
prefixLen++;
}
}
TclListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
Tcl_Size len;
const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
TclNewLiteralStringObj(elem, ".");
} else {
|
| ︙ | ︙ | |||
2167 2168 2169 2170 2171 2172 2173 |
TclListObjLength(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
Tcl_Size numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
| | | 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 |
TclListObjLength(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
Tcl_Size numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = Tcl_GetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
repair++;
}
repair = TCL_INDEX_NONE;
}
|
| ︙ | ︙ | |||
2205 2206 2207 2208 2209 2210 2211 |
* approach).
*/
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
| | | 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 |
* approach).
*/
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
(void) Tcl_GetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
switch (tclPlatform) {
case TCL_PLATFORM_WINDOWS:
if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
|
| ︙ | ︙ | |||
2251 2252 2253 2254 2255 2256 2257 |
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
Tcl_Size len;
| | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 |
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
Tcl_Size len;
const char *joined = Tcl_GetStringFromObj(joinedPtr ,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
Tcl_DStringLength(&append));
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 | * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ Tcl_Size len; | | | 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 |
* volume-relative path. In particular globbing in Windows shares,
* when not using -dir or -path, e.g. 'glob [file join
* //machine/share/subdir *]' requires adding a separator here.
* This behaviour is not currently tested for in the test suite.
*/
Tcl_Size len;
const char *joined = Tcl_GetStringFromObj(joinedPtr ,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 2003 Vince Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclFileSystem.h -- * * This file contains the common definitions and prototypes for use by * Tcl's filesystem and path handling layers. */ #ifndef _TCLFILESYSTEM #define _TCLFILESYSTEM #include "tcl.h" /* * The internal TclFS API provides routines for handling and manipulating |
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1990-1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclGet.c -- * * This file contains functions to convert strings into other forms, like * integers or floating-point numbers or booleans, doing syntax checking * along the way. */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_GetInt -- * |
| ︙ | ︙ |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 |
/*
* Copyright (c) 1992-1995 Karl Lehenbauer & Mark Diekhans.
* 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.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings. The output of
* this file should be the file tclDate.c which is used directly in the
* Tcl sources. Note that this file is largely obsolete in Tcl 8.5; it is
* only used when doing free-form date parsing, an ill-defined process
* anyway.
*/
%parse-param {DateInfo* info}
%lex-param {DateInfo* info}
%define api.pure
/* %error-verbose would be nice, but our token names are meaningless */
%locations
%{
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
* Copyright (c) 1992-1995 Karl Lehenbauer & Mark Diekhans.
* 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.
*
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Bison generates several labels that happen to be unused. MS Visual C++
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
MERIDIAN dateMeridian;
int dateHaveTime;
time_t dateTimezone;
int dateDSTmode;
int dateHaveZone;
time_t dateRelMonth;
time_t dateRelDay;
time_t dateRelSeconds;
int dateHaveRel;
time_t dateMonthOrdinal;
int dateHaveOrdinalMonth;
time_t dateDayOrdinal;
time_t dateDayNumber;
int dateHaveDay;
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC Tcl_Alloc
#define YYFREE(x) (Tcl_Free((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth)
#define yyHaveRel (info->dateHaveRel)
#define yyHaveTime (info->dateHaveTime)
#define yyHaveZone (info->dateHaveZone)
#define yyTimezone (info->dateTimezone)
#define yyDay (info->dateDay)
#define yyMonth (info->dateMonth)
#define yyYear (info->dateYear)
#define yyHour (info->dateHour)
#define yyMinutes (info->dateMinutes)
#define yySeconds (info->dateSeconds)
#define yyMeridian (info->dateMeridian)
#define yyRelMonth (info->dateRelMonth)
#define yyRelDay (info->dateRelDay)
#define yyRelSeconds (info->dateRelSeconds)
#define yyRelPointer (info->dateRelPointer)
#define yyInput (info->dateInput)
#define yyDigitCount (info->dateDigitCount)
#define EPOCH 1970
#define START_OF_TIME 1902
#define END_OF_TIME 2037
/*
* The offset of tm_year of struct tm returned by localtime, gmtime, etc.
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
#define HOUR(x) ((int) (60 * (x)))
#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
/*
* An entry in the lexical lookup table.
*/
typedef struct _TABLE {
const char *name;
int type;
time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
%}
%union {
time_t Number;
enum _MERIDIAN Meridian;
}
%{
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
DateInfo* info);
static time_t ToSeconds(time_t Hours, time_t Minutes,
time_t Seconds, MERIDIAN Meridian);
MODULE_SCOPE int yyparse(DateInfo*);
%}
%token tAGO
%token tDAY
%token tDAYZONE
%token tID
%token tMERIDIAN
%token tMONTH
%token tMONTH_UNIT
%token tSTARDATE
%token tSEC_UNIT
%token tSNUMBER
%token tUNUMBER
%token tZONE
%token tEPOCH
%token tDST
%token tISOBASE
%token tDAY_UNIT
%token tNEXT
%type <Number> tDAY
%type <Number> tDAYZONE
%type <Number> tMONTH
%type <Number> tMONTH_UNIT
%type <Number> tDST
%type <Number> tSEC_UNIT
%type <Number> tSNUMBER
%type <Number> tUNUMBER
%type <Number> tZONE
%type <Number> tISOBASE
%type <Number> tDAY_UNIT
%type <Number> unit
%type <Number> sign
%type <Number> tNEXT
%type <Number> tSTARDATE
%type <Meridian> tMERIDIAN
%type <Meridian> o_merid
%%
spec : /* NULL */
| spec item
;
item : time {
yyHaveTime++;
}
| zone {
yyHaveZone++;
}
| date {
yyHaveDate++;
}
| ordMonth {
yyHaveOrdinalMonth++;
}
| day {
yyHaveDay++;
}
| relspec {
yyHaveRel++;
}
| iso {
yyHaveTime++;
yyHaveDate++;
}
| trek {
yyHaveTime++;
yyHaveDate++;
yyHaveRel++;
}
| number
;
time : tUNUMBER tMERIDIAN {
yyHour = $1;
yyMinutes = 0;
yySeconds = 0;
yyMeridian = $2;
}
| tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = 0;
yyMeridian = $4;
}
| tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
yyHour = $1;
yyMinutes = $3;
yySeconds = $5;
yyMeridian = $6;
}
;
zone : tZONE tDST {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
| tZONE {
yyTimezone = $1;
if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
| tDAYZONE {
yyTimezone = $1;
yyDSTmode = DSTon;
}
| sign tUNUMBER {
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
yyDSTmode = DSToff;
}
;
day : tDAY {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tDAY ',' {
yyDayOrdinal = 1;
yyDayNumber = $1;
}
| tUNUMBER tDAY {
yyDayOrdinal = $1;
yyDayNumber = $2;
}
| sign tUNUMBER tDAY {
yyDayOrdinal = $1 * $2;
yyDayNumber = $3;
}
| tNEXT tDAY {
yyDayOrdinal = 2;
yyDayNumber = $2;
}
;
date : tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
}
| tUNUMBER '/' tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
yyYear = $5;
}
| tISOBASE {
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
}
| tUNUMBER '-' tMONTH '-' tUNUMBER {
yyDay = $1;
yyMonth = $3;
yyYear = $5;
}
| tUNUMBER '-' tUNUMBER '-' tUNUMBER {
yyMonth = $3;
yyDay = $5;
yyYear = $1;
}
| tMONTH tUNUMBER {
yyMonth = $1;
yyDay = $2;
}
| tMONTH tUNUMBER ',' tUNUMBER {
yyMonth = $1;
yyDay = $2;
yyYear = $4;
}
| tUNUMBER tMONTH {
yyMonth = $2;
yyDay = $1;
}
| tEPOCH {
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
| tUNUMBER tMONTH tUNUMBER {
yyMonth = $2;
yyDay = $1;
yyYear = $3;
}
;
ordMonth: tNEXT tMONTH {
yyMonthOrdinal = 1;
yyMonth = $2;
}
| tNEXT tUNUMBER tMONTH {
yyMonthOrdinal = $2;
yyMonth = $3;
}
;
iso : tUNUMBER '-' tUNUMBER '-' tUNUMBER tZONE
tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($6 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1;
yyMonth = $3;
yyDay = $5;
yyHour = $7;
yyMinutes = $9;
yySeconds = $11;
}
| tISOBASE tZONE tISOBASE {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3 / 10000;
yyMinutes = ($3 % 10000)/100;
yySeconds = $3 % 100;
}
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
if ($2 != HOUR( 7) + HOUR(100)) YYABORT;
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $3;
yyMinutes = $5;
yySeconds = $7;
}
| tISOBASE tISOBASE {
yyYear = $1 / 10000;
yyMonth = ($1 % 10000)/100;
yyDay = $1 % 100;
yyHour = $2 / 10000;
yyMinutes = ($2 % 10000)/100;
yySeconds = $2 % 100;
}
;
trek : tSTARDATE tUNUMBER '.' tUNUMBER {
/*
* Offset computed year by -377 so that the returned years will be
* in a range accessible with a 32 bit clock seconds value.
*/
yyYear = $2/1000 + 2323 - 377;
yyDay = 1;
yyMonth = 1;
yyRelDay += (($2%1000)*(365 + IsLeapYear(yyYear)))/1000;
yyRelSeconds += $4 * 144 * 60;
}
;
relspec : relunits tAGO {
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
| relunits
;
relunits : sign tUNUMBER unit {
*yyRelPointer += $1 * $2 * $3;
}
| tUNUMBER unit {
*yyRelPointer += $1 * $2;
}
| tNEXT unit {
*yyRelPointer += $2;
}
| tNEXT tUNUMBER unit {
*yyRelPointer += $2 * $3;
}
| unit {
*yyRelPointer += $1;
}
;
sign : '-' {
$$ = -1;
}
| '+' {
$$ = 1;
}
;
unit : tSEC_UNIT {
$$ = $1;
yyRelPointer = &yyRelSeconds;
}
| tDAY_UNIT {
$$ = $1;
yyRelPointer = &yyRelDay;
}
| tMONTH_UNIT {
$$ = $1;
yyRelPointer = &yyRelMonth;
}
;
number : tUNUMBER {
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = $1;
} else {
yyHaveTime++;
if (yyDigitCount <= 2) {
yyHour = $1;
yyMinutes = 0;
} else {
yyHour = $1 / 100;
yyMinutes = $1 % 100;
}
yySeconds = 0;
yyMeridian = MER24;
}
}
;
o_merid : /* NULL */ {
$$ = MER24;
}
| tMERIDIAN {
$$ = $1;
}
;
%%
/*
* Month and day table.
*/
static const TABLE MonthDayTable[] = {
{ "january", tMONTH, 1 },
{ "february", tMONTH, 2 },
{ "march", tMONTH, 3 },
{ "april", tMONTH, 4 },
{ "may", tMONTH, 5 },
{ "june", tMONTH, 6 },
{ "july", tMONTH, 7 },
{ "august", tMONTH, 8 },
{ "september", tMONTH, 9 },
{ "sept", tMONTH, 9 },
{ "october", tMONTH, 10 },
{ "november", tMONTH, 11 },
{ "december", tMONTH, 12 },
{ "sunday", tDAY, 0 },
{ "monday", tDAY, 1 },
{ "tuesday", tDAY, 2 },
{ "tues", tDAY, 2 },
{ "wednesday", tDAY, 3 },
{ "wednes", tDAY, 3 },
{ "thursday", tDAY, 4 },
{ "thur", tDAY, 4 },
{ "thurs", tDAY, 4 },
{ "friday", tDAY, 5 },
{ "saturday", tDAY, 6 },
{ NULL, 0, 0 }
};
/*
* Time units table.
*/
static const TABLE UnitsTable[] = {
{ "year", tMONTH_UNIT, 12 },
{ "month", tMONTH_UNIT, 1 },
{ "fortnight", tDAY_UNIT, 14 },
{ "week", tDAY_UNIT, 7 },
{ "day", tDAY_UNIT, 1 },
{ "hour", tSEC_UNIT, 60 * 60 },
{ "minute", tSEC_UNIT, 60 },
{ "min", tSEC_UNIT, 60 },
{ "second", tSEC_UNIT, 1 },
{ "sec", tSEC_UNIT, 1 },
{ NULL, 0, 0 }
};
/*
* Assorted relative-time words.
*/
static const TABLE OtherTable[] = {
{ "tomorrow", tDAY_UNIT, 1 },
{ "yesterday", tDAY_UNIT, -1 },
{ "today", tDAY_UNIT, 0 },
{ "now", tSEC_UNIT, 0 },
{ "last", tUNUMBER, -1 },
{ "this", tSEC_UNIT, 0 },
{ "next", tNEXT, 1 },
#if 0
{ "first", tUNUMBER, 1 },
{ "second", tUNUMBER, 2 },
{ "third", tUNUMBER, 3 },
{ "fourth", tUNUMBER, 4 },
{ "fifth", tUNUMBER, 5 },
{ "sixth", tUNUMBER, 6 },
{ "seventh", tUNUMBER, 7 },
{ "eighth", tUNUMBER, 8 },
{ "ninth", tUNUMBER, 9 },
{ "tenth", tUNUMBER, 10 },
{ "eleventh", tUNUMBER, 11 },
{ "twelfth", tUNUMBER, 12 },
#endif
{ "ago", tAGO, 1 },
{ "epoch", tEPOCH, 0 },
{ "stardate", tSTARDATE, 0 },
{ NULL, 0, 0 }
};
/*
* The timezone table. (Note: This table was modified to not use any floating
* point constants to work around an SGI compiler bug).
*/
static const TABLE TimezoneTable[] = {
{ "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
{ "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
{ "utc", tZONE, HOUR( 0) },
{ "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */
{ "wet", tZONE, HOUR( 0) }, /* Western European */
{ "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
{ "wat", tZONE, HOUR( 1) }, /* West Africa */
{ "at", tZONE, HOUR( 2) }, /* Azores */
#if 0
/* For completeness. BST is also British Summer, and GST is
* also Guam Standard. */
{ "bst", tZONE, HOUR( 3) }, /* Brazil Standard */
{ "gst", tZONE, HOUR( 3) }, /* Greenland Standard */
#endif
{ "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */
{ "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */
{ "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
{ "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */
{ "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
{ "est", tZONE, HOUR( 5) }, /* Eastern Standard */
{ "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
{ "cst", tZONE, HOUR( 6) }, /* Central Standard */
{ "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
{ "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
{ "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
{ "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
{ "akst", tZONE, HOUR( 9) }, /* Alaska Standard */
{ "akdt", tDAYZONE, HOUR( 9) }, /* Alaska Daylight */
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
{ "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
{ "nt", tZONE, HOUR(11) }, /* Nome */
{ "idlw", tZONE, HOUR(12) }, /* International Date Line West */
{ "cet", tZONE, -HOUR( 1) }, /* Central European */
{ "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
{ "met", tZONE, -HOUR( 1) }, /* Middle European */
{ "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
{ "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
{ "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */
{ "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */
{ "fwt", tZONE, -HOUR( 1) }, /* French Winter */
{ "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */
{ "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
{ "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
{ "it", tZONE, -HOUR( 7/2) }, /* Iran */
{ "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
{ "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
{ "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */
{ "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
#if 0
/* For completeness. NST is also Newfoundland Standard, and SST is
* also Swedish Summer. */
{ "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
{ "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
{ "idle", tZONE, -HOUR(12) }, /* International Date Line East */
/* ADDED BY Marco Nijdam */
{ "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
/* End ADDED */
{ NULL, 0, 0 }
};
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
{ "a", tZONE, -HOUR( 1) + HOUR(100) },
{ "b", tZONE, -HOUR( 2) + HOUR(100) },
{ "c", tZONE, -HOUR( 3) + HOUR(100) },
{ "d", tZONE, -HOUR( 4) + HOUR(100) },
{ "e", tZONE, -HOUR( 5) + HOUR(100) },
{ "f", tZONE, -HOUR( 6) + HOUR(100) },
{ "g", tZONE, -HOUR( 7) + HOUR(100) },
{ "h", tZONE, -HOUR( 8) + HOUR(100) },
{ "i", tZONE, -HOUR( 9) + HOUR(100) },
{ "k", tZONE, -HOUR(10) + HOUR(100) },
{ "l", tZONE, -HOUR(11) + HOUR(100) },
{ "m", tZONE, -HOUR(12) + HOUR(100) },
{ "n", tZONE, HOUR( 1) + HOUR(100) },
{ "o", tZONE, HOUR( 2) + HOUR(100) },
{ "p", tZONE, HOUR( 3) + HOUR(100) },
{ "q", tZONE, HOUR( 4) + HOUR(100) },
{ "r", tZONE, HOUR( 5) + HOUR(100) },
{ "s", tZONE, HOUR( 6) + HOUR(100) },
{ "t", tZONE, HOUR( 7) + HOUR(100) },
{ "u", tZONE, HOUR( 8) + HOUR(100) },
{ "v", tZONE, HOUR( 9) + HOUR(100) },
{ "w", tZONE, HOUR( 10) + HOUR(100) },
{ "x", tZONE, HOUR( 11) + HOUR(100) },
{ "y", tZONE, HOUR( 12) + HOUR(100) },
{ "z", tZONE, HOUR( 0) + HOUR(100) },
{ NULL, 0, 0 }
};
/*
* Dump error messages in the bit bucket.
*/
static void
TclDateerror(
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
Tcl_AppendToObj(infoPtr->messages, infoPtr->separatrix, -1);
Tcl_AppendToObj(infoPtr->messages, s, -1);
Tcl_AppendToObj(infoPtr->messages, " (characters ", -1);
TclNewIntObj(t, location->first_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, "-", -1);
TclNewIntObj(t, location->last_column);
Tcl_IncrRefCount(t);
Tcl_AppendObjToObj(infoPtr->messages, t);
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
static time_t
ToSeconds(
time_t Hours,
time_t Minutes,
time_t Seconds,
MERIDIAN Meridian)
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) {
return -1;
}
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23) {
return -1;
}
return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12) {
return -1;
}
return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12) {
return -1;
}
return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
* See if we have an abbreviation for a month.
*/
if (strlen(buff) == 3) {
abbrev = 1;
} else if (strlen(buff) == 4 && buff[3] == '.') {
abbrev = 1;
buff[3] = '\0';
} else {
abbrev = 0;
}
for (tp = MonthDayTable; tp->name; tp++) {
if (abbrev) {
if (strncmp(buff, tp->name, 3) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
} else if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
/*
* Strip off any plural and try the units table again.
*/
i = strlen(buff) - 1;
if (i > 0 && buff[i] == 's') {
buff[i] = '\0';
for (tp = UnitsTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
for (tp = OtherTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
/*
* Military timezones.
*/
if (buff[1] == '\0' && !(*buff & 0x80)
&& isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
/*
* Drop out any periods and try the timezone table again.
*/
for (i = 0, p = q = buff; *q; q++) {
if (*q != '.') {
*p++ = *q;
} else {
i++;
}
}
*p = '\0';
if (i) {
for (tp = TimezoneTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylvalPtr->Number = tp->value;
return tp->type;
}
}
}
return tID;
}
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
Count = 0;
for (yylvalPtr->Number = 0;
isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
yylvalPtr->Number = 10 * yylvalPtr->Number + c - '0';
Count++;
}
yyInput--;
yyDigitCount = Count;
/*
* A number with 6 or more digits is considered an ISO 8601 base.
*/
if (Count >= 6) {
location->last_column = yyInput - info->dateStart - 1;
return tISOBASE;
} else {
location->last_column = yyInput - info->dateStart - 1;
return tUNUMBER;
}
}
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
return LookupWord(yylvalPtr, buff);
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
Count = 0;
do {
c = *yyInput++;
if (c == '\0') {
location->last_column = yyInput - info->dateStart - 1;
return c;
} else if (c == '(') {
Count++;
} else if (c == ')') {
Count--;
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of parameters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"stringToParse baseYear baseMonth baseDay" );
return TCL_ERROR;
}
yyInput = TclGetString(objv[1]);
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &da) != TCL_OK) {
return TCL_ERROR;
}
yyYear = yr; yyMonth = mo; yyDay = da;
yyHaveTime = 0;
yyHour = 0; yyMinutes = 0; yySeconds = 0; yyMeridian = MER24;
yyHaveZone = 0;
yyTimezone = 0; yyDSTmode = DSTmaybe;
yyHaveOrdinalMonth = 0;
yyMonthOrdinal = 0;
yyHaveDay = 0;
yyDayOrdinal = 0; yyDayNumber = 0;
yyHaveRel = 0;
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
TclNewObj(dateInfo.messages);
dateInfo.separatrix = "";
Tcl_IncrRefCount(dateInfo.messages);
status = yyparse(&dateInfo);
if (status == 1) {
Tcl_SetObjResult(interp, dateInfo.messages);
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
return TCL_ERROR;
} else if (status == 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
return TCL_ERROR;
} else if (status != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
"from date parser. Please "
"report this error as a "
"bug in Tcl.", -1));
Tcl_DecrRefCount(dateInfo.messages);
Tcl_SetErrorCode(interp, "TCL", "BUG", (char *)NULL);
return TCL_ERROR;
}
Tcl_DecrRefCount(dateInfo.messages);
if (yyHaveDate > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one date in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveTime > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time of day in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveZone > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one time zone in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveDay > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one weekday in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
if (yyHaveOrdinalMonth > 1) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("more than one ordinal month in string", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
return TCL_ERROR;
}
TclNewObj(result);
TclNewObj(resultElement);
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyYear));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDay));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
if (yyHaveTime) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(
ToSeconds(yyHour, yyMinutes, yySeconds, (MERIDIAN)yyMeridian)));
} else {
TclNewObj(resultElement);
Tcl_ListObjAppendElement(interp, result, resultElement);
}
TclNewObj(resultElement);
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(-yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveRel) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelMonth));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelDay));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyRelSeconds));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
TclNewObj(resultElement);
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1993 The Regents of the University of California. * Copyright © 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. */ #include "tclInt.h" /* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
int *newPtr);
static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key,
int *newPtr);
static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key);
static void RebuildTable(Tcl_HashTable *tablePtr);
const Tcl_HashKeyType tclArrayHashKeyType = {
| | | | | | | | | | | | | | 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 |
int *newPtr);
static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key,
int *newPtr);
static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key);
static void RebuildTable(Tcl_HashTable *tablePtr);
const Tcl_HashKeyType tclArrayHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
TCL_HASH_KEY_RANDOMIZE_HASH,/* flags */
HashArrayKey, /* hashKeyProc */
CompareArrayKeys, /* compareKeysProc */
AllocArrayEntry, /* allocEntryProc */
NULL /* freeEntryProc */
};
const Tcl_HashKeyType tclOneWordHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
NULL, /* HashOneWordKey, */ /* hashProc */
NULL, /* CompareOneWordKey, * compareProc */
NULL, /* AllocOneWordKey, *//* allocEntryProc */
NULL /* FreeOneWordKey, */ /* freeEntryProc */
};
const Tcl_HashKeyType tclStringHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
TclHashStringKey, /* hashKeyProc */
TclCompareStringKeys, /* compareKeysProc */
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitHashTable( | < | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitHashTable(
Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied
* by the caller. */
int keyType) /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an
* integer >= 2. */
{
/*
* Use a special value to inform the extended version that it must not
|
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable( | < | | > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitCustomHashTable(
Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied
* by the caller. */
int keyType, /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS,
* or an integer >= 2. */
const Tcl_HashKeyType *typePtr)
/* Pointer to structure which defines the
* behaviour of this table. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
Tcl_Panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4",
TCL_SMALL_HASH_TABLE);
#endif
|
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
}
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
| | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != hPtr->hash) {
continue;
}
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
|| compareKeysProc((void *) key, hPtr)) {
if (newPtr) {
*newPtr = 0;
}
return hPtr;
}
}
} else { /* no direct compare - compare key addresses only */
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
/*
* tclHistory.c --
*
* This module and the Tcl library file history.tcl together implement
* Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
| > > > > > > > > > > > > > > > > > < < < < < < | 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 |
/*
* Copyright © 1990-1993 The Regents of the University of California.
* Copyright © 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclHistory.c --
*
* This module and the Tcl library file history.tcl together implement
* Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
* commands ("events") before they are executed. Commands defined in
* history.tcl may be used to perform history substitutions.
*/
#include "tclInt.h"
/*
* Type of the assocData structure used to hold the reference to the [history
* add] subcommand, used in Tcl_RecordAndEvalObj.
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998-2000 Ajuba Solutions * Copyright © 1995-1997 Sun Microsystems, Inc. * Contributions from Don Porter, NIST, 2014. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. */ #include "tclInt.h" #include "tclIO.h" #include <assert.h> /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, * there is one record of the following type. All of records for a specific |
| ︙ | ︙ | |||
164 165 166 167 168 169 170 171 172 173 174 175 176 177 | static int CheckChannelErrors(ChannelState *statePtr, int direction); static int CheckForDeadChannel(Tcl_Interp *interp, ChannelState *statePtr); static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); static void CleanupChannelHandlers(Tcl_Interp *interp, Channel *chanPtr); static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr, int errorCode); static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, int errorCode, int flags); static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyData(CopyState *csPtr, int mask); | > | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | static int CheckChannelErrors(ChannelState *statePtr, int direction); static int CheckForDeadChannel(Tcl_Interp *interp, ChannelState *statePtr); static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); static void CleanupChannelHandlers(Tcl_Interp *interp, Channel *chanPtr); static void CleanupTimerHandler(ChannelState *statePtr); static int CloseChannel(Tcl_Interp *interp, Channel *chanPtr, int errorCode); static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, int errorCode, int flags); static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyData(CopyState *csPtr, int mask); |
| ︙ | ︙ | |||
227 228 229 230 231 232 233 | const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); | | | | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static Tcl_Size Write(Channel *chanPtr, const char *src, Tcl_Size srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); #define WriteChars(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, chanPtr->state->encoding) #define WriteBytes(chanPtr, src, srcLen) \ Write(chanPtr, src, srcLen, tclIdentityEncoding) /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- |
| ︙ | ︙ | |||
310 311 312 313 314 315 316 | * Macro for testing whether a string (in optionName, length len) matches a * value (prefix matching rules). Arguments are the minimum length to match * and the value to match against. (Can't use Tcl_GetIndexFromObj as this is * used in a situation where no objects are available.) */ #define HaveOpt(minLength, nameString) \ | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | * Macro for testing whether a string (in optionName, length len) matches a * value (prefix matching rules). Arguments are the minimum length to match * and the value to match against. (Can't use Tcl_GetIndexFromObj as this is * used in a situation where no objects are available.) */ #define HaveOpt(minLength, nameString) \ ((len > (minLength)) && (optionName[1] == (nameString)[1]) \ && (strncmp(optionName, (nameString), len) == 0)) /* * The ChannelObjType type. Used to store the result of looking up * a channel name in the context of an interp. Saves the lookup * result and values needed to check its continued validity. */ |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
} ResolvedChanName;
static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void FreeChannelInternalRep(Tcl_Obj *objPtr);
static const Tcl_ObjType chanObjType = {
"channel", /* name for this type */
| | | < > | | | | > | | | | | 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 |
} ResolvedChanName;
static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void FreeChannelInternalRep(Tcl_Obj *objPtr);
static const Tcl_ObjType chanObjType = {
"channel", /* name for this type */
FreeChannelInternalRep, /* freeIntRepProc */
DupChannelInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
#define ChanSetInternalRep(objPtr, resPtr) \
do { \
Tcl_ObjInternalRep ir; \
(resPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (resPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \
} while (0)
#define ChanGetInternalRep(objPtr, resPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &chanObjType); \
(resPtr) = irPtr \
? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define BUSY_STATE(statePtr, flags) \
((((statePtr)->csPtrR) && ((flags) & TCL_READABLE)) || \
(((statePtr)->csPtrW) && ((flags) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
/*
*---------------------------------------------------------------------------
*
* ChanClose, ChanRead, ChanSeek, ChanThreadAction, ChanWatch, ChanWrite --
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
void
Tcl_CreateCloseHandler(
Tcl_Channel chan, /* The channel for which to create the close
* callback. */
Tcl_CloseProc *proc, /* The callback routine to call when the
* channel will be closed. */
| | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
void
Tcl_CreateCloseHandler(
Tcl_Channel chan, /* The channel for which to create the close
* callback. */
Tcl_CloseProc *proc, /* The callback routine to call when the
* channel will be closed. */
void *clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
cbPtr = (CloseCallback *)Tcl_Alloc(sizeof(CloseCallback));
cbPtr->proc = proc;
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
void
Tcl_DeleteCloseHandler(
Tcl_Channel chan, /* The channel for which to cancel the close
* callback. */
Tcl_CloseProc *proc, /* The procedure for the callback to
* remove. */
| | | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 |
void
Tcl_DeleteCloseHandler(
Tcl_Channel chan, /* The channel for which to cancel the close
* callback. */
Tcl_CloseProc *proc, /* The procedure for the callback to
* remove. */
void *clientData) /* The callback data for the callback to
* remove. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr, *cbPrevPtr;
for (cbPtr = statePtr->closeCbPtr, cbPrevPtr = NULL;
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 | * registered in this interpreter. * *---------------------------------------------------------------------- */ static void DeleteChannelTable( | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
* registered in this interpreter.
*
*----------------------------------------------------------------------
*/
static void
DeleteChannelTable(
void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
Tcl_HashTable *hTblPtr; /* The hash table. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* Channel being deleted. */
ChannelState *statePtr; /* State of Channel being deleted. */
|
| ︙ | ︙ | |||
1590 1591 1592 1593 1594 1595 1596 | * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_CreateChannel( | | > | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 |
* Creates a new Tcl_Channel instance and inserts it into the hash table.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_CreateChannel(
const Tcl_ChannelType *typePtr,
/* The channel type record. */
const char *chanName, /* Name of channel to record. */
void *instanceData, /* Instance specific data. */
int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if
* the channel is readable, writable. */
{
Channel *chanPtr; /* The channel structure newly created. */
ChannelState *statePtr; /* The stack-level independent state info for
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
strcpy(tmp, chanName);
} else {
tmp = (char *)Tcl_Alloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
*/
name = Tcl_GetEncodingName(NULL);
| > > > > | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 |
strcpy(tmp, chanName);
} else {
tmp = (char *)Tcl_Alloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
/* uncomment this to make default encoding error handling strict */
/*
statePtr->flags |= CHANNEL_ENCODING_STRICT;
*/
statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
*/
name = Tcl_GetEncodingName(NULL);
|
| ︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 |
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelHandle(
Tcl_Channel chan, /* The channel to get file from. */
int direction, /* TCL_WRITABLE or TCL_READABLE. */
| | | 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 |
*----------------------------------------------------------------------
*/
int
Tcl_GetChannelHandle(
Tcl_Channel chan, /* The channel to get file from. */
int direction, /* TCL_WRITABLE or TCL_READABLE. */
void **handlePtr) /* Where to store handle */
{
Channel *chanPtr; /* The actual channel. */
void *handle;
int result;
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
if (!chanPtr->typePtr->getHandleProc) {
|
| ︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 | * May leave an error message in the interp. * *---------------------------------------------------------------------- */ int Tcl_RemoveChannelMode( | | > | | | 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
* May leave an error message in the interp.
*
*----------------------------------------------------------------------
*/
int
Tcl_RemoveChannelMode(
Tcl_Interp *interp, /* The interp for an error message. Allowed to
* be NULL. */
Tcl_Channel chan, /* The channel which is modified. */
int mode) /* The access mode to drop from the channel */
{
const char* emsg;
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of actual channel. */
if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
emsg = "Illegal mode value.";
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 | * None. * *--------------------------------------------------------------------------- */ static ChannelBuffer * AllocChannelBuffer( | | | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 |
* None.
*
*---------------------------------------------------------------------------
*/
static ChannelBuffer *
AllocChannelBuffer(
Tcl_Size length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
Tcl_Size n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *)Tcl_Alloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
* referenced in any interpreter. May be NULL,
* in which case this is a no-op. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
| | | 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 |
* referenced in any interpreter. May be NULL,
* in which case this is a no-op. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
int result = 0; /* Of calling FlushChannel. */
int flushcode;
int stickyError;
if (chan == NULL) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
| > > > > > | 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 |
TclDecrRefCount(statePtr->chanMsg);
statePtr->chanMsg = NULL;
}
}
Tcl_ClearChannelHandlers(chan);
/*
* Cancel any outstanding timer.
*/
DeleteTimerHandler(statePtr);
/*
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
|
| ︙ | ︙ | |||
4058 4059 4060 4061 4062 4063 4064 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Write(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
| | | | 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Write(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE
* for strlen(). */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
|
| ︙ | ︙ | |||
4170 4171 4172 4173 4174 4175 4176 |
*/
Tcl_Size
Tcl_WriteChars(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* UTF-8 characters to queue in output
* buffer. */
| | | | 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 |
*/
Tcl_Size
Tcl_WriteChars(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* UTF-8 characters to queue in output
* buffer. */
Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE
* for strlen(). */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* State info for channel */
Tcl_Size result;
Tcl_Obj *objPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
|
| ︙ | ︙ | |||
4271 4272 4273 4274 4275 4276 4277 |
Tcl_SetErrno(EILSEQ);
result = TCL_INDEX_NONE;
} else {
result = WriteBytes(chanPtr, src, srcLen);
}
return result;
} else {
| | | 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 |
Tcl_SetErrno(EILSEQ);
result = TCL_INDEX_NONE;
} else {
result = WriteBytes(chanPtr, src, srcLen);
}
return result;
} else {
src = Tcl_GetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
static void
WillWrite(
Channel *chanPtr)
|
| ︙ | ︙ | |||
4665 4666 4667 4668 4669 4670 4671 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
| | | 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
(void)Tcl_GetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
5231 5232 5233 5234 5235 5236 5237 |
byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen);
memcpy(byteArray + byteLen, dst, rawLen);
byteLen += rawLen;
bufPtr->nextRemoved += rawLen + skip;
/*
* Convert the buffer if there was an encoding.
| < > | 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 |
byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen);
memcpy(byteArray + byteLen, dst, rawLen);
byteLen += rawLen;
bufPtr->nextRemoved += rawLen + skip;
/*
* Convert the buffer if there was an encoding.
*/
if (statePtr->encoding != GetBinaryEncoding()) {
// XXX - unimplemented!
}
/*
* Recycle all the emptied buffers.
*/
CommonGetsCleanup(chanPtr);
|
| ︙ | ︙ | |||
5711 5712 5713 5714 5715 5716 5717 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Read(
Tcl_Channel chan, /* The channel from which to read. */
char *dst, /* Where to store input read. */
| | | 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Read(
Tcl_Channel chan, /* The channel from which to read. */
char *dst, /* Where to store input read. */
Tcl_Size bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
/*
* This operation should occur at the top of a channel stack.
|
| ︙ | ︙ | |||
5756 5757 5758 5759 5760 5761 5762 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_ReadRaw(
Tcl_Channel chan, /* The channel from which to read. */
char *readBuf, /* Where to store input read. */
| | | 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_ReadRaw(
Tcl_Channel chan, /* The channel from which to read. */
char *readBuf, /* Where to store input read. */
Tcl_Size bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
int copied = 0;
assert(bytesToRead > 0);
|
| ︙ | ︙ | |||
5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: UpdateInterest not needed here? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
/*
* Early out when next read will see eofchar.
*
| > | 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 |
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
/* TODO: UpdateInterest not needed here? */
UpdateInterest(chanPtr);
Tcl_SetErrno(EILSEQ);
return -1;
}
/*
* Early out when next read will see eofchar.
*
|
| ︙ | ︙ | |||
6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 |
* after the EOF character was encountered, so it doesn't count as
* a real error.
*/
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_STICKY_EOF)
&& (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
goto finish;
}
}
if (copiedNow < 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
| > | 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 |
* after the EOF character was encountered, so it doesn't count as
* a real error.
*/
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_STICKY_EOF)
&& (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
copied = -1;
goto finish;
}
}
if (copiedNow < 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
break;
|
| ︙ | ︙ | |||
6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 |
* like [read] can also return an error.
*/
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
Tcl_SetErrno(EILSEQ);
copied = -1;
}
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
}
/*
*---------------------------------------------------------------------------
*
* ReadBytes --
| > > > | 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 |
* like [read] can also return an error.
*/
ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_ENCODING_ERROR);
Tcl_SetErrno(EILSEQ);
copied = -1;
}
TclChannelRelease((Tcl_Channel)chanPtr);
if (copied == TCL_INDEX_NONE) {
ResetFlag(statePtr, CHANNEL_ENCODING_ERROR|CHANNEL_EOF);
}
return copied;
}
/*
*---------------------------------------------------------------------------
*
* ReadBytes --
|
| ︙ | ︙ | |||
6266 6267 6268 6269 6270 6271 6272 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
if (dstLimit <= 0) {
dstLimit = INT_MAX; /* avoid overflow */
}
| | | 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
if (dstLimit <= 0) {
dstLimit = INT_MAX; /* avoid overflow */
}
(void) Tcl_GetStringFromObj(objPtr, &numBytes);
TclAppendUtfToUtf(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
Tcl_Size size;
dst = TclGetStringStorage(objPtr, &size) + numBytes;
dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes);
} else {
|
| ︙ | ︙ | |||
6807 6808 6809 6810 6811 6812 6813 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Ungets(
Tcl_Channel chan, /* The channel for which to add the input. */
const char *str, /* The input itself. */
| | | 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 |
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_Ungets(
Tcl_Channel chan, /* The channel for which to add the input. */
const char *str, /* The input itself. */
Tcl_Size len, /* The length of the input. */
int atEnd) /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of actual channel. */
ChannelBuffer *bufPtr; /* Buffer to contain the data. */
int flags;
|
| ︙ | ︙ | |||
7780 7781 7782 7783 7784 7785 7786 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(
Tcl_Channel chan, /* The channel whose buffer size to set. */
| | | 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(
Tcl_Channel chan, /* The channel whose buffer size to set. */
Tcl_Size sz) /* The size to set. */
{
ChannelState *statePtr; /* State of real channel structure. */
/*
* Clip the buffer size to force it into the [1,1M] range
*/
|
| ︙ | ︙ | |||
8289 8290 8291 8292 8293 8294 8295 |
statePtr->outputEncodingFlags = TCL_ENCODING_START;
ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */
ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
UpdateInterest(chanPtr);
return TCL_OK;
} else if (HaveOpt(2, "-eofchar")) {
if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1]
| < < | 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 |
statePtr->outputEncodingFlags = TCL_ENCODING_START;
ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */
ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR);
UpdateInterest(chanPtr);
return TCL_OK;
} else if (HaveOpt(2, "-eofchar")) {
if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1]
|| !strcmp(newValue+1, " {}")
))) {
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = newValue[0];
}
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 |
TclChannelPreserve((Tcl_Channel)chanPtr);
statePtr->timerChanPtr = chanPtr;
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
| > > > > > > > > > > > > > > > | 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 |
TclChannelPreserve((Tcl_Channel)chanPtr);
statePtr->timerChanPtr = chanPtr;
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
}
}
}
if (!statePtr->timer
&& (mask & TCL_WRITABLE)
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
&& ( statePtr->curOutPtr
&& !IsBufferEmpty(statePtr->curOutPtr)
&& !IsBufferFull(statePtr->curOutPtr)
)
) {
TclChannelPreserve((Tcl_Channel)chanPtr);
statePtr->timerChanPtr = chanPtr;
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME
,ChannelTimerProc ,chanPtr);
}
ChanWatch(chanPtr, mask);
}
/*
*----------------------------------------------------------------------
*
* ChannelTimerProc --
|
| ︙ | ︙ | |||
8783 8784 8785 8786 8787 8788 8789 8790 8791 |
static void
ChannelTimerProc(
void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
/* State info for channel */
ChannelState *statePtr = chanPtr->state;
if (chanPtr->typePtr == NULL) {
| > > > > > > | < < | > | | | | > > > > > > > > > > > > | > > | < | | | < > > | | > > > > > > > | > | > | | < | 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 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 |
static void
ChannelTimerProc(
void *clientData)
{
Channel *chanPtr = (Channel *)clientData;
/* State info for channel */
ChannelState *statePtr = chanPtr->state;
/* TclChannelPreserve() must be called before the current function was
* scheduled, is already in effect. In this function it guards against
* deallocation in Tcl_NotifyChannel and also keps the channel preserved
* until ChannelTimerProc is later called again.
*/
if (chanPtr->typePtr == NULL) {
CleanupTimerHandler(statePtr);
} else {
Tcl_Preserve(statePtr);
statePtr->timer = NULL;
if (statePtr->interestMask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
&& !GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
} else {
/* The channel may have just been closed from within Tcl_NotifyChannel */
if (!GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
&& (statePtr->interestMask & TCL_READABLE)
&& (statePtr->inQueueHead != NULL)
&& IsBufferReady(statePtr->inQueueHead)) {
/*
* Restart the timer in case a channel handler reenters the event loop
* before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
ChannelTimerProc, chanPtr);
Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
} else {
CleanupTimerHandler(statePtr);
UpdateInterest(chanPtr);
}
} else {
CleanupTimerHandler(statePtr);
}
}
Tcl_Release(statePtr);
}
}
static void
DeleteTimerHandler(
ChannelState *statePtr)
{
if (statePtr->timer != NULL) {
Tcl_DeleteTimerHandler(statePtr->timer);
CleanupTimerHandler(statePtr);
}
}
static void
CleanupTimerHandler(
ChannelState *statePtr)
{
TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
statePtr->timer = NULL;
statePtr->timerChanPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateChannelHandler --
*
* Arrange for a given procedure to be invoked whenever the channel
|
| ︙ | ︙ | |||
8854 8855 8856 8857 8858 8859 8860 |
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. Use 0 to disable a registered
* handler. */
Tcl_ChannelProc *proc, /* Procedure to call for each selected
* event. */
| | | 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 |
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. Use 0 to disable a registered
* handler. */
Tcl_ChannelProc *proc, /* Procedure to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ChannelHandler *chPtr;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
/*
|
| ︙ | ︙ | |||
8926 8927 8928 8929 8930 8931 8932 |
*/
void
Tcl_DeleteChannelHandler(
Tcl_Channel chan, /* The channel for which to remove the
* callback. */
Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */
| | | 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 |
*/
void
Tcl_DeleteChannelHandler(
Tcl_Channel chan, /* The channel for which to remove the
* callback. */
Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */
void *clientData) /* The client data in the callback to
* delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelHandler *chPtr, *prevChPtr;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
|
| ︙ | ︙ | |||
9132 9133 9134 9135 9136 9137 9138 | * Whatever the script does. * *---------------------------------------------------------------------- */ void TclChannelEventScriptInvoker( | | | 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 |
* Whatever the script does.
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(
void *clientData, /* The script+interp record. */
TCL_UNUSED(int) /*mask*/)
{
EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
/* The event script + interpreter to eval it
* in. */
Channel *chanPtr = esPtr->chanPtr;
/* The channel for which this handler is
|
| ︙ | ︙ | |||
9775 9776 9777 9778 9779 9780 9781 |
sizeb = csPtr->bufSize;
} else {
sizeb = csPtr->toRead;
}
if (moveBytes) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
| | | | | | 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 |
sizeb = csPtr->bufSize;
} else {
sizeb = csPtr->toRead;
}
if (moveBytes) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING),
0 /* No append */);
/*
* In case of a recoverable encoding error, any data before
* the error should be written. This data is in the bufObj.
* Program flow for this case:
* - Check, if there are any remaining bytes to write
* - If yes, simulate a successful read to write them out
* - Come back here by the outer loop and read again
* - Do not enter in the if below, as there are no pending
* writes
* - Fail below with a read error
*/
if (size < 0 && Tcl_GetErrno() == EILSEQ) {
Tcl_GetStringFromObj(bufObj, &sizePart);
if (sizePart > 0) {
size = sizePart;
}
}
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
|
| ︙ | ︙ | |||
9861 9862 9863 9864 9865 9866 9867 |
* Now write the buffer out.
*/
if (moveBytes) {
buffer = csPtr->buffer;
sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size);
} else {
| | | 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 |
* Now write the buffer out.
*/
if (moveBytes) {
buffer = csPtr->buffer;
sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size);
} else {
buffer = Tcl_GetStringFromObj(bufObj, &sizeb);
sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb);
}
/*
* [Bug 2895565]. At this point 'size' still contains the number of
* characters which have been read. We keep this to later to
* update the totals and toRead information, see marker (UP) below. We
|
| ︙ | ︙ | |||
10048 10049 10050 10051 10052 10053 10054 |
*----------------------------------------------------------------------
*/
static Tcl_Size
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
| | | 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 |
*----------------------------------------------------------------------
*/
static Tcl_Size
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
Tcl_Size bytesToRead, /* Maximum number of bytes to read. */
int allowShortReads) /* Allow half-blocking (pipes,sockets) */
{
ChannelState *statePtr = chanPtr->state;
char *p = dst;
/*
* Early out when we know a read will get the eofchar.
|
| ︙ | ︙ | |||
11438 11439 11440 11441 11442 11443 11444 | * representation. * *---------------------------------------------------------------------- */ static void DupChannelInternalRep( | | | | 11507 11508 11509 11510 11511 11512 11513 11514 11515 11516 11517 11518 11519 11520 11521 11522 11523 |
* representation.
*
*----------------------------------------------------------------------
*/
static void
DupChannelInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
* an internal rep of type "Channel". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
ResolvedChanName *resPtr;
ChanGetInternalRep(srcPtr, resPtr);
assert(resPtr);
ChanSetInternalRep(copyPtr, resPtr);
|
| ︙ | ︙ | |||
11495 11496 11497 11498 11499 11500 11501 |
DumpFlags(
char *str,
int flags)
{
int i = 0;
char buf[24];
| | | 11564 11565 11566 11567 11568 11569 11570 11571 11572 11573 11574 11575 11576 11577 11578 |
DumpFlags(
char *str,
int flags)
{
int i = 0;
char buf[24];
#define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
ChanFlag('r', TCL_READABLE);
ChanFlag('w', TCL_WRITABLE);
ChanFlag('n', CHANNEL_NONBLOCKING);
ChanFlag('l', CHANNEL_LINEBUFFERED);
ChanFlag('u', CHANNEL_UNBUFFERED);
ChanFlag('F', BG_FLUSH_SCHEDULED);
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1998-2000 Ajuba Solutions * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIO.h -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. */ /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not * compile on systems where neither is defined. We want both defined so that * we can test safely for both. In the code we still have to test for both * because there may be systems on which both are defined and have different * values. */ |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
void *instanceData; /* Instance-specific data provided by creator
* of channel. */
| | > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
* specific) instance data, and at a channel type structure.
*/
typedef struct Channel {
struct ChannelState *state; /* Split out state information */
void *instanceData; /* Instance-specific data provided by creator
* of channel. */
const Tcl_ChannelType *typePtr;
/* Pointer to channel type structure. */
struct Channel *downChanPtr;/* Refers to channel this one was stacked
* upon. This reference is NULL for normal
* channels. See Tcl_StackChannel. */
struct Channel *upChanPtr; /* Refers to the channel above stacked this
* one. NULL for the top most channel. */
/*
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 |
/* What translation to apply for end of line
* sequences on input? */
TclEolTranslation outputTranslation;
/* What translation to use for generating end
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
| < < < < < | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
/* What translation to apply for end of line
* sequences on input? */
TclEolTranslation outputTranslation;
/* What translation to use for generating end
* of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
Tcl_Size refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. */ #include "tclInt.h" #include "tclIO.h" #include "tclTomMath.h" /* * Callback structure for accept callback in a TCP server. */ |
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
}
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
| < | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
}
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
/*
* 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.
*/
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
| | | | > | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
Tcl_WideInt toRead; /* How many bytes to read? */
Tcl_Size charactersRead; /* How many characters were read? */
int mode; /* Mode in which channel is opened. */
Tcl_Obj *resultPtr, *resultDictPtr, *returnOptsPtr, *chanObjPtr;
int res, status;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv, "channel ?numChars?");
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
}
}
TclNewObj(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
| < < < < < < < < | > > > > | > > > > > | | | 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 |
}
}
TclNewObj(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
* put them into the regular interpreter result. Fall back to the
* regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
status = TclCheckEmptyString(interp, resultPtr, &res);
if (!status && !res) {
resultDictPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1)
, resultPtr);
returnOptsPtr = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1)
, resultDictPtr);
Tcl_SetReturnOptions(interp, returnOptsPtr);
} else {
Tcl_DecrRefCount(resultPtr);
}
TclChannelRelease(chan);
return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
Tcl_Size length;
result = Tcl_GetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
TclChannelRelease(chan);
return TCL_OK;
|
| ︙ | ︙ | |||
710 711 712 713 714 715 716 |
const char *string;
Tcl_Size len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
| | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
const char *string;
Tcl_Size len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = Tcl_GetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
return TCL_OK;
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
TclStackFree(interp, (void *) argv);
if (chan == NULL) {
return TCL_ERROR;
}
| < < < < < | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 |
TclStackFree(interp, (void *) argv);
if (chan == NULL) {
return TCL_ERROR;
}
if (background) {
/*
* Store the list of PIDs from the pipeline in interp's result and
* detach the PIDs (instead of waiting for them).
*/
TclGetAndDetachPids(interp, chan);
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 |
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
string = Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
|
| ︙ | ︙ | |||
1235 1236 1237 1238 1239 1240 1241 | * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ static void TcpAcceptCallbacksDeleteProc( | | | 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
* subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
static void
TcpAcceptCallbacksDeleteProc(
void *clientData, /* Data which was passed when the assocdata
* was registered. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 | * Whatever the script does. * *---------------------------------------------------------------------- */ static void AcceptCallbackProc( | | | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
* Whatever the script does.
*
*----------------------------------------------------------------------
*/
static void
AcceptCallbackProc(
void *callbackData, /* The data stored when the callback was
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
|
| ︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 | * longer be informed. * *---------------------------------------------------------------------- */ static void TcpServerCloseProc( | | | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
* longer be informed.
*
*----------------------------------------------------------------------
*/
static void
TcpServerCloseProc(
void *callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2000 Ajuba Solutions * Copyright © 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API at the * script level. Contributed by Andreas Kupries. */ #include "tclInt.h" #include "tclIO.h" /* * Forward declarations of internal procedures. First the driver procedures of * the transformation. */ |
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
Tcl_Size resLen = 0;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
| | > > > > | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
Tcl_Size resLen = 0;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclDuplicatePureObj(
interp, dataPtr->command, tclListTypePtr);
if (!command) {
return TCL_ERROR;
}
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
/*
* Step 1, create the complete command to execute. Do this by appending
* operation and buffer to operate upon to a copy of the callback
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 | * 0 if successful, errno when failed. * *---------------------------------------------------------------------- */ static int TransformBlockModeProc( | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
* 0 if successful, errno when failed.
*
*----------------------------------------------------------------------
*/
static int
TransformBlockModeProc(
void *instanceData, /* State of transformation. */
int mode) /* New blocking mode. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
dataPtr->flags |= CHANNEL_ASYNC;
} else {
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 | * None. * *---------------------------------------------------------------------- */ static void TransformWatchProc( | | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
* None.
*
*----------------------------------------------------------------------
*/
static void
TransformWatchProc(
void *instanceData, /* Channel to watch. */
int mask) /* Events of interest. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan;
/*
* The caller expressed interest in events occurring for this channel. We
|
| ︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 | * The appropriate Tcl_File or NULL if not present. * *---------------------------------------------------------------------- */ static int TransformGetFileHandleProc( | | | | 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 |
* The appropriate Tcl_File or NULL if not present.
*
*----------------------------------------------------------------------
*/
static int
TransformGetFileHandleProc(
void *instanceData, /* Channel to query. */
int direction, /* Direction of interest. */
void **handlePtr) /* Place to store the handle into. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
/*
* Return the handle belonging to parent channel. IOW, pass the request
* down and the result up.
*/
|
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 | * None. * *---------------------------------------------------------------------- */ static int TransformNotifyProc( | | | 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TransformNotifyProc(
void *clientData, /* The state of the notified
* transformation. */
int mask) /* The mask of occurring events. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
/*
* An event occurred in the underlying channel. This transformation doesn't
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 | * None. * *---------------------------------------------------------------------- */ static void TransformChannelHandlerTimer( | | | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 |
* None.
*
*----------------------------------------------------------------------
*/
static void
TransformChannelHandlerTimer(
void *clientData) /* Transformation to query. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
dataPtr->timer = NULL;
if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) {
/*
* The timer fired, but either is there no (more) interest in the
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | /* * tclIORChan.c -- * * This file contains the implementation of Tcl's generic channel * reflection code, which allows the implementation of Tcl channels in * Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #219 for the specification of this functionality. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2004-2005 ActiveState, a division of Sophos * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIORChan.c -- * * This file contains the implementation of Tcl's generic channel * reflection code, which allows the implementation of Tcl channels in * Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #219 for the specification of this functionality. */ #include "tclInt.h" #include "tclIO.h" #include <assert.h> #ifndef EINVAL |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static int ReflectTruncate(void *clientData,
long long length);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType reflectedChannelType = {
"tclrchannel",
| > > | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(void *clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static int ReflectTruncate(void *clientData,
long long length);
static void TimerRunRead(void *clientData);
static void TimerRunWrite(void *clientData);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType reflectedChannelType = {
"tclrchannel",
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
/*
* Note regarding the usage of timers.
*
* Most channel implementations need a timer in the C level to ensure that
* data in buffers is flushed out through the generation of fake file
* events.
*
* See 'refchan', 'memchan', etc.
*
| > > > > > > > < < | < | > | 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 |
int mode; /* Mask of R/W mode */
int interest; /* Mask of events the channel is interested
* in. */
int dead; /* Boolean signal that some operations
* should no longer be attempted. */
Tcl_TimerToken readTimer; /* A token for the timer that is scheduled in
* order to call Tcl_NotifyChannel when the
* channel is readable */
Tcl_TimerToken writeTimer; /* A token for the timer that is scheduled in
* order to call Tcl_NotifyChannel when the
* channel is writable */
/*
* Note regarding the usage of timers.
*
* Most channel implementations need a timer in the C level to ensure that
* data in buffers is flushed out through the generation of fake file
* events.
*
* See 'refchan', 'memchan', etc.
*
* A timer is used here as well in order to ensure at least on pass through
* the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
* ef28eb1f1516.
*/
} ReflectedChannel;
/*
* Structure of the table mapping from channel handles to reflected
* channels. Each interpreter which has the handler command for one or more
* reflected channels records them in such a table, so that 'chan postevent'
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) | | < | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | \ FLAG(METH_CGETALL) | FLAG(METH_TRUNCATE)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a, b) ((!(a)) || (b)) #define HAS(x, f) ((x) & FLAG(f)) #if TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. |
| ︙ | ︙ | |||
386 387 388 389 390 391 392 | */ static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); | | | | | | | | | | | | > | | | | | | | | | | | | 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 |
*/
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(void *clientData);
#define FreeReceivedError(fwdParam) \
if ((fwdParam)->base.mustFree) { \
Tcl_Free((fwdParam)->base.msgStr); \
}
#define PassReceivedErrorInterp(interp, fwdParam) \
if ((interp) != NULL) { \
Tcl_SetChannelErrorInterp((interp), \
Tcl_NewStringObj((fwdParam)->base.msgStr, -1)); \
} \
FreeReceivedError(fwdParam)
#define PassReceivedError(chan, fwdParam) \
Tcl_SetChannelError((chan), \
Tcl_NewStringObj((fwdParam)->base.msgStr, -1)); \
FreeReceivedError(fwdParam)
#define ForwardSetStaticError(fwdParam, emsg) \
(fwdParam)->base.code = TCL_ERROR; \
(fwdParam)->base.mustFree = 0; \
(fwdParam)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(fwdParam, emsg) \
(fwdParam)->base.code = TCL_ERROR; \
(fwdParam)->base.mustFree = 1; \
(fwdParam)->base.msgStr = (char *) (emsg)
static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
static ReflectedChannelMap * GetThreadReflectedChannelMap(void);
static Tcl_ExitProc DeleteThreadReflectedChannelMap;
#endif /* TCL_THREADS */
#define SetChannelErrorStr(chan, msgStr) \
Tcl_SetChannelError((chan), Tcl_NewStringObj((msgStr), -1))
static Tcl_Obj * MarshallError(Tcl_Interp *interp);
static void UnmarshallErrorResult(Tcl_Interp *interp,
Tcl_Obj *msgObj);
/*
* Static functions for this file:
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
/*
* We have the channel and the events to post.
*/
#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
| | > > > > > > > > > > > | 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 |
/*
* We have the channel and the events to post.
*/
#if TCL_THREADS
if (rcPtr->owner == rcPtr->thread) {
#endif
if (events & TCL_READABLE) {
if (rcPtr->readTimer == NULL) {
rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunRead, rcPtr);
}
}
if (events & TCL_WRITABLE) {
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 983 984 985 986 987 988 989 |
/*
* Squash interp results left by the event script.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
| > > > > > > > > > > > > > > > > > > | 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 |
/*
* Squash interp results left by the event script.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
static void
TimerRunRead(
void *clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->readTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}
static void
TimerRunWrite(
void *clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->writeTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}
/*
* Channel error message marshalling utilities.
*/
static Tcl_Obj *
MarshallError(
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 |
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
| > > > > > > | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 |
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return EOK;
}
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &reflectedChannelType) {
Tcl_Free((void *)tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
}
Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 |
#endif
blockObj = Tcl_NewBooleanObj(!nonblocking);
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
| | | 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 |
#endif
blockObj = Tcl_NewBooleanObj(!nonblocking);
Tcl_IncrRefCount(blockObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
errorNum = EINVAL;
} else {
errorNum = EOK;
}
Tcl_DecrRefCount(blockObj);
|
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectSetOption( | | | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 |
* Arbitrary, as it calls upon a Tcl script.
*
*----------------------------------------------------------------------
*/
static int
ReflectSetOption(
void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj, *valueObj;
int result; /* Result code for 'configure' */
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 |
optionObj = Tcl_NewStringObj(optionName, -1);
valueObj = Tcl_NewStringObj(newValue, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
| | | 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
optionObj = Tcl_NewStringObj(optionName, -1);
valueObj = Tcl_NewStringObj(newValue, -1);
Tcl_IncrRefCount(optionObj);
Tcl_IncrRefCount(valueObj);
result = InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, &resObj);
if (result != TCL_OK) {
UnmarshallErrorResult(interp, resObj);
}
Tcl_DecrRefCount(optionObj);
Tcl_DecrRefCount(valueObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectGetOption( | | | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 |
* Arbitrary, as it calls upon a Tcl script.
*
*----------------------------------------------------------------------
*/
static int
ReflectGetOption(
void *clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
/*
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
|
| ︙ | ︙ | |||
1958 1959 1960 1961 1962 1963 1964 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
Tcl_Size len;
| | | 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
Tcl_Size len;
const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
}
|
| ︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 | * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ static int ReflectTruncate( | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
* Arbitrary, as it calls upon a Tcl script.
*
*----------------------------------------------------------------------
*/
static int
ReflectTruncate(
void *clientData, /* Channel to query */
long long length) /* Length to truncate to. */
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *lenObj;
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result for 'truncate' */
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
/* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */
Tcl_Preserve(rcPtr);
lenObj = Tcl_NewWideIntObj(length);
Tcl_IncrRefCount(lenObj);
| | | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 |
/* ASSERT: rcPtr->method & FLAG(METH_TRUNCATE) */
Tcl_Preserve(rcPtr);
lenObj = Tcl_NewWideIntObj(length);
Tcl_IncrRefCount(lenObj);
if (InvokeTclMethod(rcPtr, METH_TRUNCATE, lenObj, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rcPtr->chan, resObj);
errorNum = EINVAL;
} else {
errorNum = EOK;
}
Tcl_DecrRefCount(lenObj);
|
| ︙ | ︙ | |||
2082 2083 2084 2085 2086 2087 2088 |
EncodeEventMask(
Tcl_Interp *interp,
const char *objName,
Tcl_Obj *obj,
int *mask)
{
int events; /* Mask of events to post */
| | | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 |
EncodeEventMask(
Tcl_Interp *interp,
const char *objName,
Tcl_Obj *obj,
int *mask)
{
int events; /* Mask of events to post */
Tcl_Size listc; /* #elements in eventspec list */
Tcl_Obj **listv; /* Elements of eventspec list */
int evIndex; /* Id of event for an element of the eventspec
* list. */
if (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 |
rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
| > > > | > > | 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 |
rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
rcPtr->readTimer = 0;
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, tclListTypePtr);
if (!rcPtr->cmd) {
return NULL;
}
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
Tcl_NewStringObj(methodNames[mn++], -1));
}
Tcl_IncrRefCount(rcPtr->methods);
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 |
if (rcPtr->dead) {
/*
* The channel is marked as dead. Bail out immediately, with an
* appropriate error.
*/
if (resultObjPtr != NULL) {
| | | > > > | 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 |
if (rcPtr->dead) {
/*
* The channel is marked as dead. Bail out immediately, with an
* appropriate error.
*/
if (resultObjPtr != NULL) {
resObj = Tcl_NewStringObj(msg_dstlost, -1);
*resultObjPtr = resObj;
Tcl_IncrRefCount(resObj);
}
/*
* Not touching argOneObj, argTwoObj, they have not been used.
* See the contract as well.
*/
return TCL_ERROR;
}
/*
* Insert method into the callback command, after the command prefix,
* before the channel id.
*/
cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, tclListTypePtr);
if (!cmd) {
return TCL_ERROR;
}
Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj);
Tcl_ListObjAppendElement(NULL, cmd, methObj);
Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name);
/*
* Append the additional argument containing method specific details
* behind the channel id. If specified.
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Size cmdLen;
| | | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Size cmdLen;
const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
cmdLen);
|
| ︙ | ︙ | |||
2559 2560 2561 2562 2563 2564 2565 |
}
CleanRefChannelInstance(rcPtr);
rcPtr->dead = 1;
}
static void
DeleteReflectedChannelMap(
| | | | | 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 |
}
CleanRefChannelInstance(rcPtr);
rcPtr->dead = 1;
}
static void
DeleteReflectedChannelMap(
void *clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData;
/* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
#if TCL_THREADS
ForwardingResult *resultPtr;
ForwardingEvent *evPtr;
ForwardParam *paramPtr;
#endif
|
| ︙ | ︙ | |||
3269 3270 3271 3272 3273 3274 3275 |
snprintf(buf, 200,
"{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "d %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
Tcl_Size len;
| | | | 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 |
snprintf(buf, 200,
"{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "d %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
Tcl_Size 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;
case ForwardedTruncate: {
Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length);
Tcl_IncrRefCount(lenObj);
Tcl_Preserve(rcPtr);
if (InvokeTclMethod(rcPtr, METH_TRUNCATE, lenObj, NULL, &resObj)!=TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(lenObj);
break;
}
|
| ︙ | ︙ | |||
3381 3382 3383 3384 3385 3386 3387 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
| | | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | /* * tclIORTrans.c -- * * This file contains the implementation of Tcl's generic transformation * reflection code, which allows the implementation of Tcl channel * transformations in Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #230 for the specification of this functionality. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2007-2008 ActiveState. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIORTrans.c -- * * This file contains the implementation of Tcl's generic transformation * reflection code, which allows the implementation of Tcl channel * transformations in Tcl code. * * Parts of this file are based on code contributed by Jean-Claude * Wippler. * * See TIP #230 for the specification of this functionality. */ #include "tclInt.h" #include "tclIO.h" #include <assert.h> #ifndef EINVAL |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 | #define FLAG(m) (1 << (m)) #define REQUIRED_METHODS \ (FLAG(METH_INIT) | FLAG(METH_FINAL)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) | | | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | #define FLAG(m) (1 << (m)) #define REQUIRED_METHODS \ (FLAG(METH_INIT) | FLAG(METH_FINAL)) #define RANDW \ (TCL_READABLE | TCL_WRITABLE) #define IMPLIES(a, b) ((!(a)) || (b)) #define NEGIMPL(a, b) #define HAS(x, f) ((x) & FLAG(f)) #if TCL_THREADS /* * Thread specific types and structures. * * We are here essentially creating a very specific implementation of 'thread * send'. |
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | */ static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, ForwardedOperation op, const void *param); static int ForwardProc(Tcl_Event *evPtr, int mask); static void SrcExitProc(void *clientData); | | | | | | | | | | | | | | | | | | | | | | | | 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 |
*/
static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(void *clientData);
#define FreeReceivedError(fwdParam) \
do { \
if ((fwdParam)->base.mustFree) { \
Tcl_Free((fwdParam)->base.msgStr); \
} \
} while (0)
#define PassReceivedErrorInterp(interp, fwdParam) \
do { \
if ((interp) != NULL) { \
Tcl_SetChannelErrorInterp((interp), \
Tcl_NewStringObj((fwdParam)->base.msgStr, -1)); \
} \
FreeReceivedError(fwdParam); \
} while (0)
#define PassReceivedError(chan, fwdParam) \
do { \
Tcl_SetChannelError((chan), \
Tcl_NewStringObj((fwdParam)->base.msgStr, -1)); \
FreeReceivedError(fwdParam); \
} while (0)
#define ForwardSetStaticError(fwdParam, emsg) \
do { \
(fwdParam)->base.code = TCL_ERROR; \
(fwdParam)->base.mustFree = 0; \
(fwdParam)->base.msgStr = (char *) (emsg); \
} while (0)
#define ForwardSetDynamicError(fwdParam, emsg) \
do { \
(fwdParam)->base.code = TCL_ERROR; \
(fwdParam)->base.mustFree = 1; \
(fwdParam)->base.msgStr = (char *) (emsg); \
} while (0)
static void ForwardSetObjError(ForwardParam *p,
Tcl_Obj *objPtr);
static ReflectedTransformMap * GetThreadReflectedTransformMap(void);
static void DeleteThreadReflectedTransformMap(
void *clientData);
#endif /* TCL_THREADS */
#define SetChannelErrorStr(chan, msgStr) \
Tcl_SetChannelError((chan), Tcl_NewStringObj((msgStr), -1))
static Tcl_Obj * MarshallError(Tcl_Interp *interp);
static void UnmarshallErrorResult(Tcl_Interp *interp,
Tcl_Obj *msgObj);
/*
* Static functions for this file:
|
| ︙ | ︙ | |||
1919 1920 1921 1922 1923 1924 1925 |
if (rtPtr->dead) {
/*
* The transform is marked as dead. Bail out immediately, with an
* appropriate error.
*/
if (resultObjPtr != NULL) {
| | | 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 |
if (rtPtr->dead) {
/*
* The transform is marked as dead. Bail out immediately, with an
* appropriate error.
*/
if (resultObjPtr != NULL) {
resObj = Tcl_NewStringObj(msg_dstlost, -1);
*resultObjPtr = resObj;
Tcl_IncrRefCount(resObj);
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
Tcl_Size cmdLen;
| | | 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 |
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
Tcl_Size cmdLen;
const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(cmd);
|
| ︙ | ︙ | |||
2763 2764 2765 2766 2767 2768 2769 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
| | | 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 |
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif /* TCL_THREADS */
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIOSock.c -- * * Common routines used by all socket based channel types. */ #include "tclInt.h" #if defined(_WIN32) /* * On Windows, we need to do proper Unicode->UTF-8 conversion. */ |
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
const char *family = NULL;
Tcl_DString ds;
int result;
if (host != NULL) {
if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds,
NULL) != TCL_OK) {
| | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
const char *family = NULL;
Tcl_DString ds;
int result;
if (host != NULL) {
if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return 0;
}
native = Tcl_DStringValue(&ds);
}
/*
* Workaround for OSX's apparent inability to resolve "localhost", "0"
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | /* * tclIOUtil.c -- * * Provides an interface for managing filesystems in Tcl, and also for * creating a filesystem interface in Tcl arbitrary facilities. All * filesystem operations are performed via this interface. Vince Darley * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. | > > > > > > > > > > > > > > > > > > < < < < < < < | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2001-2004 Vincent Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIOUtil.c -- * * Provides an interface for managing filesystems in Tcl, and also for * creating a filesystem interface in Tcl arbitrary facilities. All * filesystem operations are performed via this interface. Vince Darley * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. */ #include "tclInt.h" #include "tclIO.h" #ifdef _WIN32 # include "tclWinInt.h" #endif |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
Tcl_Stat(
const char *path, /* Pathname of file to stat (in current system
* encoding). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
| | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
Tcl_Stat(
const char *path, /* Pathname of file to stat (in current system
* encoding). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSStat(pathPtr, &buf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt tmp1, tmp2, tmp3 = 0;
|
| ︙ | ︙ | |||
328 329 330 331 332 333 334 |
int
Tcl_Access(
const char *path, /* Pathname of file to access (in current
* system encoding). */
int mode) /* Permission setting. */
{
int ret;
| | | | | | 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 |
int
Tcl_Access(
const char *path, /* Pathname of file to access (in current
* system encoding). */
int mode) /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSAccess(pathPtr, mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. May be
* NULL. */
const char *path, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
int permissions) /* The modes to use if creating a new file. */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
int
Tcl_Chdir(
const char *dirName)
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName, -1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSChdir(pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
const char *fileName) /* Pathname of the file containing the script.
* Performs Tilde-substitution on this
* pathaname. */
{
int ret;
| | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
const char *fileName) /* Pathname of the file containing the script.
* Performs Tilde-substitution on this
* pathaname. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName, -1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSEvalFile(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
Tcl_Size len1, len2;
const char *str1, *str2;
| | | | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
Tcl_Size len1, len2;
const char *str1, *str2;
str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* The values are equal but the objects are different. Cache the
* current structure in place of the old one.
*/
Tcl_DecrRefCount(*pathPtrPtr);
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
void *clientData)
{
Tcl_Size len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
| | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
void *clientData)
{
Tcl_Size len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdClientData != NULL) {
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
* i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
| | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 |
* i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
mount = Tcl_GetStringFromObj(mElt, &mlen);
path = Tcl_GetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
*/
len--;
}
|
| ︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 |
* are reserved for VFS use. These names can not conflict with real UNC
* pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
| | | 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 |
* are reserved for VFS use. These names can not conflict with real UNC
* pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
path = Tcl_GetStringFromObj(pathPtr, &i);
if ((i >= 3) && ((path[0] == '/' && path[1] == '/')
|| (path[0] == '\\' && path[1] == '\\'))) {
for (i = 2; ; i++) {
if (path[i] == '\0') {
break;
}
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
}
mode = (mode & ~O_ACCMODE) | O_RDWR;
gotRW = 1;
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
if (mode & O_APPEND) {
accessFlagRepeated:
if (interp) {
| | | | | 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 |
}
mode = (mode & ~O_ACCMODE) | O_RDWR;
gotRW = 1;
} else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
if (mode & O_APPEND) {
accessFlagRepeated:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" repeated", flag));
}
goto invAccessMode;
}
mode |= O_APPEND;
*modeFlagsPtr |= 1;
} else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
if (mode & O_CREAT) {
goto accessFlagRepeated;
}
mode |= O_CREAT;
} else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
if (mode & O_EXCL) {
goto accessFlagRepeated;
}
mode |= O_EXCL;
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 |
*/
if (encodingName == NULL) {
encodingName = "utf-8";
}
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_CloseEx(interp,chan,0);
return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
| > > > > > | 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 |
*/
if (encodingName == NULL) {
encodingName = "utf-8";
}
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_CloseEx(interp, chan, 0);
return result;
}
if (Tcl_SetChannelOption(interp, chan, "-profile", "strict")
!= TCL_OK) {
Tcl_CloseEx(interp,chan,0);
return result;
}
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 |
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
| | | 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 |
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
| | | 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 |
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : (int)length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
Tcl_Size length;
| | | 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 |
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
Tcl_Size length;
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : (int)length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 | /* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code to the given value. On some saner platforms | | | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 | /* *---------------------------------------------------------------------- * * Tcl_SetErrno -- * * Sets the Tcl error code to the given value. On some saner platforms * this is implemented in the C library as a thread-local value, but this * is *really* unsafe to assume! * * Results: * None. * * Side effects: * Modifies the the Tcl error code value. |
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 |
static int
NativeFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
Tcl_Obj *pathPtr, /* Pathname of the file */
Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */
{
| | | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 |
static int
NativeFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
Tcl_Obj *pathPtr, /* Pathname of the file */
Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */
{
return tclpFileAttrProcs[index].getProc(interp, index, pathPtr, objPtrRef);
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsSet --
*
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 | /* * Found the pathname of the current directory. */ retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); | | | 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 |
/*
* Found the pathname of the current directory.
*/
retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm != NULL) {
/*
* Assign to global storage the pathname of the current
* directory and copy it into thread-local storage as
* well.
*
* At system startup multiple threads could in principle
|
| ︙ | ︙ | |||
2781 2782 2783 2784 2785 2786 2787 |
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
}
norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm == NULL) {
| | | | | | 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 |
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
}
norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm == NULL) {
/*
* 'norm' shouldn't ever be NULL, but we are careful.
*/
/* Do nothing */
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
}
} else if (norm == tsdPtr->cwdPathPtr) {
goto cdEqual;
} else {
/*
* Determine whether the filesystem's answer is the same as the
* cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr'
* are normalized pathnames, do something more efficient than
* calling 'Tcl_FSEqualPaths', and in addition avoid a nasty
* infinite loop bug when trying to normalize tsdPtr->cwdPathPtr.
*/
Tcl_Size len1, len2;
const char *str1, *str2;
str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = Tcl_GetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
* The pathname values are equal so retain the old pathname
* object which is probably already shared and free the
* normalized pathname that was just produced.
*/
cdEqual:
|
| ︙ | ︙ | |||
3903 3904 3905 3906 3907 3908 3909 |
* length of the volume name. */
Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
* place to store a pointer to an object with a
* refCount of 1, and whose value is the name
* of the volume. */
{
Tcl_Size pathLen;
| | | 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 |
* length of the volume name. */
Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
* place to store a pointer to an object with a
* refCount of 1, and whose value is the name
* of the volume. */
{
Tcl_Size pathLen;
const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
|
| ︙ | ︙ | |||
4010 4011 4012 4013 4014 4015 4016 |
while (numVolumes > 0) {
Tcl_Obj *vol;
Tcl_Size len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
| | | 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 |
while (numVolumes > 0) {
Tcl_Obj *vol;
Tcl_Size len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = Tcl_GetStringFromObj(vol ,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
|
| ︙ | ︙ | |||
4370 4371 4372 4373 4374 4375 4376 |
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
Tcl_Size cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
| | | | 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 |
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
Tcl_Size cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
normLen) == 0)) {
/*
* The cwd is inside the directory to be removed. Change
* the cwd to [file dirname $path].
*/
|
| ︙ | ︙ | |||
4632 4633 4634 4635 4636 4637 4638 |
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
}
| | | 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 |
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
}
return Tcl_NewStringObj(separator, 1);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1990-1994 The Regents of the University of California. * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 2006 Sam Bromley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type is used * to lookup a keyword in a table of valid values and cache the index of * the matching entry. Also provides table-based argv/argc processing. */ #include "tclInt.h" /* * Prototypes for functions defined later in this file: */ static int GetIndexFromObjList(Tcl_Interp *interp, |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
const Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL, /* setFromAnyProc */
| < > | | 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 |
const Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
* The definition of the internal representation of the "index" object; The
* internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
*/
typedef struct {
void *tablePtr; /* Pointer to the table of strings */
Tcl_Size offset; /* Offset between table entries */
Tcl_Size index; /* Selected index into table. */
} IndexRep;
/*
* The following macros greatly simplify moving through a table...
*/
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
| | > | | | | | | | | | | | | | 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 |
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (objPtr && (index != TCL_INDEX_NONE)
&& !(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjInternalRep ir;
indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep));
ir.twoPtrValue.ptr1 = indexRep;
Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
uncachedDone:
if (indexPtr != NULL) {
flags &= (30-(int)(sizeof(int)<<1));
if (flags) {
if (flags == sizeof(uint16_t)<<1) {
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
| | | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
string = Tcl_GetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
*/
if (length <= elemLength) {
if (TclpUtfNcmp2(elemString, string, length) == 0) {
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
| | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 |
return TCL_ERROR;
}
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
string = Tcl_GetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
* cannot match if it is longest.
*/
if ((length > elemLength) ||
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
*
*----------------------------------------------------------------------
*/
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
| | | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
*
*----------------------------------------------------------------------
*/
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments to print from objv. */
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
868 869 870 871 872 873 874 |
if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
| | | 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 |
if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
| | | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = Tcl_GetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
Tcl_Size nrem; /* Size of leftovers.*/
| | < | | | | 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 |
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
Tcl_Size nrem; /* Size of leftovers.*/
const Tcl_ArgvInfo *infoPtr;/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
/* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
Tcl_Size srcIndex; /* Location from which to read next argument
* from objv. */
Tcl_Size dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
Tcl_Size objc; /* # arguments in objv still to process. */
Tcl_Size length; /* Number of characters in current argument */
Tcl_Size gf_ret; /* Return value from Tcl_ArgvGenFuncProc*/
if (remObjv != NULL) {
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 |
srcIndex = dstIndex = 1;
objc = *objcPtr-1;
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
| | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
srcIndex = dstIndex = 1;
objc = *objcPtr-1;
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
str = Tcl_GetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
c = 0;
}
/*
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # tclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file # is used to generate the tclIntDecls.h, tclIntPlatDecls.h # and tclStubInit.c files # | > > > > > > > > > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 2001 Kevin B. Kenny. All rights reserved. # Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # tclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file # is used to generate the tclIntDecls.h, tclIntPlatDecls.h # and tclStubInit.c files # library tcl # Define the unsupported generic interfaces. interface tclInt scspec EXTERN |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
declare 10 {
| > > > > > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
# Removed in 9.0:
#declare 8 {
# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
#}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
declare 10 {
|
| ︙ | ︙ | |||
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 |
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 {
int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
# Removed in 9.0:
#declare 121 {
# int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
# const char *pattern)
#}
#declare 122 {
# Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
#}
#declare 123 {
# void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
# Tcl_Obj *objPtr)
#}
#declare 124 {
# Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
#}
#declare 125 {
# Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
#}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
# Removed in 9.0:
#declare 127 {
# int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
# const char *pattern, int allowOverwrite)
#}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 {
int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
# Removed in 9.0:
#declare 132 {
# int TclpHasSockets(Tcl_Interp *interp)
#}
# Removed in 9.0:
#declare 133 {
# struct tm *TclpGetDate(const time_t *time, int useGMT)
#}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(void *clientData, int flags)
}
| > > > > > > > > | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
# Removed in 9.0:
#declare 158 {
# void TclSetStartupScriptFileName(const char *filename)
#}
#declare 159 {
# const char *TclGetStartupScriptFileName(void)
#}
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(void *clientData, int flags)
}
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Size index, Tcl_Obj *valuePtr)
}
# variant of Tcl_UtfNcmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const void *s1, const void *s2, size_t n)
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags,
| > > > > > > > | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Size index, Tcl_Obj *valuePtr)
}
# Removed in 9.0:
#declare 167 {
# void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
#}
#declare 168 {
# Tcl_Obj *TclGetStartupScriptPath(void)
#}
# variant of Tcl_UtfNcmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const void *s1, const void *s2, size_t n)
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags,
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
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)
}
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
| > > > > > > > > > > > > > > > > | 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 |
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)
}
# Removed in 9.0:
#declare 178 {
# void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
#}
#declare 179 {
# Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
#}
#declare 182 {
# struct tm *TclpLocaltime(const time_t *clock)
#}
#declare 183 {
# struct tm *TclpGmtime(const time_t *clock)
#}
# For the new "Thread Storage" subsystem.
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# 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
| > > > > | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
# Removed in 9.0:
#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
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
# only available on the designated platform.
interface tclIntPlat
################################
# Platform specific functions
declare 1 {
int TclpCloseFile(TclFile file)
}
declare 2 {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr)
}
| > > > > | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
# only available on the designated platform.
interface tclIntPlat
################################
# Platform specific functions
# Removed in 9.0
#declare 0 {unix win} {
# void TclWinConvertError(unsigned errCode)
#}
declare 1 {
int TclpCloseFile(TclFile file)
}
declare 2 {
Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr)
}
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 by Miguel Sofer. All rights reserved. * Copyright (c) 2021 by Nathan Coulter. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclInt.h -- * * Declarations of things used internally by the Tcl interpreter. */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options. */ |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif #if defined(__cplusplus) # define TCL_UNUSED(T) T #elif defined(__GNUC__) && (__GNUC__ > 2) # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused)) #else # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is | > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif #if defined(__cplusplus) # define TCL_UNUSED(T) T # define TCL_UNUSEDVAR(T) T #elif defined(__GNUC__) && (__GNUC__ > 2) # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused)) # define TCL_UNUSEDVAR(T) T __attribute__((unused)) #else # define TCL_UNUSED(T) T JOIN(dummy, __LINE__) # define TCL_UNUSEDVAR(T) T #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is |
| ︙ | ︙ | |||
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 |
* different rules:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
#define TCL_AVOID_RESOLVERS 0x40000
/*
*----------------------------------------------------------------
* Data structures related to namespaces.
*----------------------------------------------------------------
*/
typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;
/*
* Special hashtable for variables: This is just a Tcl_HashTable with nsPtr
* and arrayPtr fields added at the end so that variables can find their
* namespace and possibly containing array without having to copy a pointer in
* their struct by accessing them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
Tcl_HashTable table; /* "Inherit" from Tcl_HashTable. */
struct Namespace *nsPtr; /* The namespace containing the variables. */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | 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 |
* different rules:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
#define TCL_AVOID_RESOLVERS 0x40000
/*
*----------------------------------------------------------------
* Object type
*----------------------------------------------------------------
*/
/* version is a pointer so that it can be overridden if ever needed */
typedef struct TclObjectTypeType {
int *version;
} TclObjectTypeType;
/* keep this structure in sync with Tcl_ObjType */
typedef struct ObjectType {
const char *name; /* Name of the type, e.g. "int". */
Tcl_FreeInternalRepProc *freeIntRepProc;
/* Called to free any storage for the type's
* internal rep. NULL if the internal rep does
* not need freeing. */
Tcl_DupInternalRepProc *dupIntRepProc;
/* Called to create a new object as a copy of
* an existing object. */
Tcl_UpdateStringProc *updateStringProc;
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
int version;
Tcl_ObjInterface *ifPtr; /* pointer to a functional interface */
} ObjectType;
#define TclObjectInterfaceCall(objPtr, iface, proc, ...) \
((ObjInterface *)((ObjectType *)(objPtr)->typePtr)->ifPtr) \
->iface.proc(__VA_ARGS__)
#define TclObjectDispatch(objPtr, default, iface, proc, ...) \
TclObjectHasInterface((objPtr), iface, proc) \
? TclObjectInterfaceCall(objPtr, iface, proc, __VA_ARGS__) \
: default(__VA_ARGS__)
#define TclObjectDispatchNoDefault(interp, res, objPtr, iface, proc, ...) \
(TclObjectHasInterface((objPtr), iface, proc) \
? ((res) = TclObjectInterfaceCall((objPtr), iface, proc, __VA_ARGS__), \
TCL_OK) \
: (Tcl_SetObjResult((interp), \
Tcl_ObjPrintf("interface error interface %s proc %s\n%s" \
, #iface, #proc, \
Tcl_GetStringFromObj( \
Tcl_GetObjResult(interp) ,NULL))), TCL_ERROR))
#define TclObjectHasInterface(objPtr, iface, proc) \
( \
(objPtr)->typePtr != NULL \
&&TclObjInterface(objPtr) != NULL \
&& TclObjInterface(objPtr)->iface.proc != NULL \
)
/*
*----------------------------------------------------------------
* Object interface data structures and macros
*----------------------------------------------------------------
*/
typedef struct ObjInterface {
int version;
struct string {
int (*index)(tclObjTypeInterfaceArgsStringIndex);
int (*indexEnd)(tclObjTypeInterfaceArgsStringIndexEnd);
int (*isEmpty)(tclObjTypeInterfaceArgsStringIsEmpty);
int (*length)(tclObjTypeInterfaceArgsStringLength);
int (*range)(tclObjTypeInterfaceArgsStringRange);
int (*rangeEnd)(tclObjTypeInterfaceArgsStringRangeEnd);
} string;
struct list {
int (*all)(tclObjTypeInterfaceArgsListAll);
int (*append)(tclObjTypeInterfaceArgsListAppend);
int (*appendlist)(tclObjTypeInterfaceArgsListAppendList);
int (*contains)(tclObjTypeInterfaceArgsListContains);
int (*index)(tclObjTypeInterfaceArgsListIndex);
int (*indexEnd)(tclObjTypeInterfaceArgsListIndexEnd);
int (*isSorted)(tclObjTypeInterfaceArgsListIsSorted);
int (*length)(tclObjTypeInterfaceArgsListLength);
int (*range)(tclObjTypeInterfaceArgsListRange);
int (*rangeEnd)(tclObjTypeInterfaceArgsListRangeEnd);
int (*replace)(tclObjTypeInterfaceArgsListReplace);
int (*replaceList)(tclObjTypeInterfaceArgsListReplaceList);
int (*reverse)(tclObjTypeInterfaceArgsListReverse);
int (*set)(tclObjTypeInterfaceArgsListSet);
int (*setDeep)(tclObjTypeInterfaceArgsListSetDeep);
} list;
} ObjInterface;
/*
*----------------------------------------------------------------
* Data structures related to namespaces.
*----------------------------------------------------------------
*/
typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;
/*
* Special hashtable for variables: This is just a Tcl_HashTable with nsPtr
* and arrayPtr fields added at the end so that variables can find their
* namespace and possibly containing array without having to copy a pointer in
* their struct by accessing them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
Tcl_HashTable table; /* "Inherit" from Tcl_HashTable. */
struct Namespace *nsPtr; /* The namespace containing the variables. */
struct Var *arrayPtr; /* The array containing the variables, if they
* are variables in an array at all. */
} TclVarHashTable;
/*
* This is for itcl - it likes to search our varTables directly :(
*/
#define TclVarHashFindVar(tablePtr, key) \
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
| < < < < | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
size_t nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
Tcl_Size activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 | /* * Flags passed to TclGetNamespaceForQualName: * * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns. * TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces. * TCL_FIND_ONLY_NS - The name sought is a namespace name. | < < < | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 | /* * Flags passed to TclGetNamespaceForQualName: * * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns. * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns. * TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces. * TCL_FIND_ONLY_NS - The name sought is a namespace name. */ #define TCL_CREATE_NS_IF_UNKNOWN 0x800 #define TCL_FIND_ONLY_NS 0x1000 /* * The client data for an ensemble command. This consists of the table of * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, * defines whether the table contains valid data or will need to be recomputed * next time the ensemble command is called. |
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
#define TclSetVarConstant(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT
#define TclSetVarArrayElement(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT
#define TclSetVarUndefined(varPtr) \
| | | | | | | | | | | | | | 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 |
#define TclSetVarConstant(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT
#define TclSetVarArrayElement(varPtr) \
(varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT
#define TclSetVarUndefined(varPtr) \
(varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT); \
(varPtr)->value.objPtr = NULL
#define TclClearVarUndefined(varPtr)
#define TclSetVarTraceActive(varPtr) \
(varPtr)->flags |= VAR_TRACE_ACTIVE
#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);
* MODULE_SCOPE int TclIsVarConstant(Var *varPtr);
* MODULE_SCOPE int TclIsVarLink(Var *varPtr);
* MODULE_SCOPE int TclIsVarArray(Var *varPtr);
* MODULE_SCOPE int TclIsVarUndefined(Var *varPtr);
* MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr);
* MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
* MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
* MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
*/
#define TclVarFindHiddenArray(varPtr, arrayPtr) \
do { \
if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \
(TclVarParentArray(varPtr) != NULL)) { \
arrayPtr = TclVarParentArray(varPtr); \
} \
} while(0)
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
#define TclIsVarInHash(varPtr) \
((varPtr)->flags & VAR_IN_HASHTABLE)
#define TclIsVarDeadHash(varPtr) \
((varPtr)->flags & VAR_DEAD_HASH)
#define TclGetVarNsPtr(varPtr) \
| | | | | | > | | > | | | | 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 |
#define TclIsVarInHash(varPtr) \
((varPtr)->flags & VAR_IN_HASHTABLE)
#define TclIsVarDeadHash(varPtr) \
((varPtr)->flags & VAR_DEAD_HASH)
#define TclGetVarNsPtr(varPtr) \
(TclIsVarInHash(varPtr) \
? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
: NULL)
#define TclVarParentArray(varPtr) \
((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr
#define VarHashRefCount(varPtr) \
((VarInHash *) (varPtr))->refCount
#define VarHashGetKey(varPtr) \
(((VarInHash *)(varPtr))->entry.key.objPtr)
/*
* Macros for direct variable access by TEBC.
*/
#define TclIsVarTricky(varPtr, trickyFlags) \
( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \
|| (TclIsVarInHash(varPtr) \
&& (TclVarParentArray(varPtr) != NULL) \
&& (TclVarParentArray(varPtr)->flags & (trickyFlags))))
#define TclIsVarDirectReadable(varPtr) \
( (!TclIsVarTricky(varPtr, VAR_TRACED_READ)) \
&& (varPtr)->value.objPtr)
#define TclIsVarDirectWritable(varPtr) \
(!TclIsVarTricky(varPtr, VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT))
#define TclIsVarDirectUnsettable(varPtr) \
(!TclIsVarTricky(varPtr, \
VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT))
#define TclIsVarDirectModifyable(varPtr) \
( (!TclIsVarTricky(varPtr, \
VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \
&& (varPtr)->value.objPtr)
#define TclIsVarDirectReadable2(varPtr, arrayPtr) \
(TclIsVarDirectReadable(varPtr) && \
(!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ)))
#define TclIsVarDirectWritable2(varPtr, arrayPtr) \
(TclIsVarDirectWritable(varPtr) && \
(!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE)))
#define TclIsVarDirectModifyable2(varPtr, arrayPtr) \
(TclIsVarDirectModifyable(varPtr) && \
(!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE))))
/*
*----------------------------------------------------------------
* Data structures related to procedures. These are used primarily in
* tclProc.c, tclCompile.c, and tclExecute.c.
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
Tcl_Size nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
| < < < < < | 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 |
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
Tcl_Size nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
Tcl_Size frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
Tcl_Obj *defValuePtr; /* Pointer to the default value of an
* argument, if any. NULL if not an argument
* or, if an argument, no default value. */
Tcl_ResolvedVarInfo *resolveInfo;
/* Customized variable resolution info
* supplied by the Tcl_ResolveCompiledVarProc
* associated with a namespace. Each variable
* is marked by a unique tag during
* compilation, and that same tag is used to
* find the variable at runtime. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If
* the name is NULL, this will just be '\0'.
* The actual size of this field will be large
* enough to hold the name. MUST BE THE LAST
* FIELD IN THE STRUCTURE! */
} CompiledLocal;
|
| ︙ | ︙ | |||
1050 1051 1052 1053 1054 1055 1056 |
* The structure below defines a command trace. This is used to allow Tcl
* clients to find out whenever a command is about to be executed.
*/
typedef struct Trace {
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
| < < < < | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 |
* The structure below defines a command trace. This is used to allow Tcl
* clients to find out whenever a command is about to be executed.
*/
typedef struct Trace {
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */
void *clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details. */
Tcl_CmdObjTraceDeleteProc *delProc;
/* Procedure to call when trace is deleted. */
} Trace;
|
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 | * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 | * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 /* * The structure below defines an entry in the assocData hash table which is * associated with an interpreter. The entry contains a pointer to a function * to call when the interpreter is deleted, and a pointer to a user-defined * piece of data. */ |
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
| < < < < < < < < < < < < < | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of parent/child interps on a
* per-interp basis. */
void (*optimizer)(void *envPtr);
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
Tcl_Size numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
|
| ︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
| < < < < < < | 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
* available to this interpreter. Keys are
* package names, values are (Package *)
|
| ︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 |
Tcl_Size cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
| < < < | 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 |
Tcl_Size cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
Tcl_Size compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
|
| ︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
| < < < | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
|
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 |
Tcl_Obj *returnOpts; /* A dictionary holding the options to the
* last [return] command. */
Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj). */
Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */
Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */
| | | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
Tcl_Obj *returnOpts; /* A dictionary holding the options to the
* last [return] command. */
Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj). */
Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */
Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */
Tcl_Obj *ecVar; /* cached ref to ::errorCode variable. */
int returnLevel; /* [return -level] parameter. */
/*
* Resource limiting framework support (TIP#143).
*/
struct {
|
| ︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 | * caller plans on recording its own traceback * information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* * ListStore -- * * A Tcl list's internal representation is defined through three structures. * * A ListStore struct is a structure that includes a variable size array that | > | 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 | * caller plans on recording its own traceback * information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* * ListStore -- * * A Tcl list's internal representation is defined through three structures. * * A ListStore struct is a structure that includes a variable size array that |
| ︙ | ︙ | |||
2643 2644 2645 2646 2647 2648 2649 | * be a list (tclListType). Will crash otherwise. * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not * be tclListType. These will convert as needed and return error if * conversion not possible. */ /* Returns the starting slot for this listRep in the contained ListStore */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
* be a list (tclListType). Will crash otherwise.
* TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
* be tclListType. These will convert as needed and return error if
* conversion not possible.
*/
/* Returns the starting slot for this listRep in the contained ListStore */
#define ListRepStart(listRepPtr) \
((listRepPtr)->spanPtr \
? (listRepPtr)->spanPtr->spanStart \
: (listRepPtr)->storePtr->firstUsed)
/* Returns the number of elements in this listRep */
#define ListRepLength(listRepPtr) \
((listRepPtr)->spanPtr \
? (listRepPtr)->spanPtr->spanLength \
: (listRepPtr)->storePtr->numUsed)
/* Returns a pointer to the first slot containing this ListRep elements */
#define ListRepElementsBase(listRepPtr) \
(&(listRepPtr)->storePtr->slots[ListRepStart(listRepPtr)])
/* Stores the number of elements and base address of the element array */
#define ListRepElements(listRepPtr, objc, objv) \
(((objv) = ListRepElementsBase(listRepPtr)), \
((objc) = ListRepLength(listRepPtr)))
/* Returns 1/0 whether the ListRep's ListStore is shared. */
#define ListRepIsShared(listRepPtr) ((listRepPtr)->storePtr->refCount > 1)
/* Returns a pointer to the ListStore component */
#define ListObjStorePtr(listObj) \
((ListStore *)((listObj)->internalRep.twoPtrValue.ptr1))
/* Returns a pointer to the ListSpan component */
#define ListObjSpanPtr(listObj) \
((ListSpan *)((listObj)->internalRep.twoPtrValue.ptr2))
/* Returns the ListRep internal representaton in a Tcl_Obj */
#define ListObjGetRep(listObj, listRepPtr) \
do { \
(listRepPtr)->storePtr = ListObjStorePtr(listObj); \
(listRepPtr)->spanPtr = ListObjSpanPtr(listObj); \
} while (0)
/* Retrieves the length of the list */
#define ListObjLength(listObj, len) \
((len) = ListObjSpanPtr(listObj) \
? ListObjSpanPtr(listObj)->spanLength \
: ListObjStorePtr(listObj)->numUsed)
/* Returns the starting slot index of this list's elements in the ListStore */
#define ListObjStart(listObj) \
(ListObjSpanPtr(listObj) \
? ListObjSpanPtr(listObj)->spanStart \
: ListObjStorePtr(listObj)->firstUsed)
/* Stores the element count and base address of this list's elements */
#define ListObjGetElements(listObj, objc, objv) \
(((objv) = &ListObjStorePtr(listObj)->slots[ListObjStart(listObj)]), \
(ListObjLength(listObj, (objc))))
/*
* Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
* is shared. Note by intent this only checks for sharing of ListStore,
* not spans.
*/
#define ListObjRepIsShared(listObj) \
(ListObjStorePtr(listObj)->refCount > 1)
/*
* Certain commands like concat are optimized if an existing string
* representation of a list object is known to be in canonical format (i.e.
* generated from the list representation). There are three conditions when
* this will be the case:
* (1) No string representation exists which means it will obviously have
|
| ︙ | ︙ | |||
2732 2733 2734 2735 2736 2737 2738 | /* * Converts the Tcl_Obj to a list if it isn't one and stores the element * count and base address of this list's elements in objcPtr_ and objvPtr_. * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be * converted to a list. */ | | | | | | | | | | < | | | | < < < < < < < < | | | | | | | | | | | | | | | | | | | | | > | | | 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 |
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count and base address of this list's elements in objcPtr_ and objvPtr_.
* Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
* converted to a list.
*/
#define TclListObjGetElements(interp_, listObj_, objcPtr_, objvPtr_) \
((TclHasInternalRep((listObj_) ,tclListTypePtr)) \
? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
TCL_OK) \
: Tcl_ListObjGetElements( \
(interp_), (listObj_), (objcPtr_), (objvPtr_)))
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
* Tcl_Obj cannot be converted to a list.
*/
#define TclListObjLength(interp_, listObj_, lenPtr_) \
((TclHasInternalRep((listObj_), tclListTypePtr)) \
? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
: Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
#define TclListObjIsCanonical(listObj_) \
((TclHasInternalRep((listObj_), tclListTypePtr)) \
? ListObjIsCanonical((listObj_)) \
: 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
*/
#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
* Macros providing a faster path to booleans and integers:
* Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
* and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr)) \
|| TclHasInternalRep((objPtr), tclBooleanTypePtr) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr)) \
? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr) \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#endif
#define TclGetIntFromObj(interp, objPtr, intPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr) \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
(((TclHasInternalRep((objPtr), tclIntTypePtr)) \
&& ((objPtr)->internalRep.wideValue >= 0) \
&& ((objPtr)->internalRep.wideValue <= endValue)) \
? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
* Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* Tcl_WideInt *wideIntPtr);
*/
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
((TclHasInternalRep((objPtr), tclIntTypePtr)) \
? (*(wideIntPtr) = \
((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
/*
* Flag values for TclTraceDictPath().
*
* DICT_PATH_READ indicates that all entries on the path must exist but no
* updates will be needed.
*
|
| ︙ | ︙ | |||
2990 2991 2992 2993 2994 2995 2996 | *---------------------------------------------------------------------- * Internal convenience macros for manipulating encoding flags. See * TCL_ENCODING_PROFILE_* in tcl.h *---------------------------------------------------------------------- */ #define ENCODING_PROFILE_MASK 0xFF000000 | | | | | | | 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 |
*----------------------------------------------------------------------
* Internal convenience macros for manipulating encoding flags. See
* TCL_ENCODING_PROFILE_* in tcl.h
*----------------------------------------------------------------------
*/
#define ENCODING_PROFILE_MASK 0xFF000000
#define ENCODING_PROFILE_GET(flags) \
((flags) & ENCODING_PROFILE_MASK)
#define ENCODING_PROFILE_SET(flags, profile) \
do { \
(flags) &= ~ENCODING_PROFILE_MASK; \
(flags) |= ((profile) & ENCODING_PROFILE_MASK); \
} while (0)
/*
*----------------------------------------------------------------------
* Common functions for calculating overallocation. Trivial but allows for
* experimenting with growth factors without having to change code in
* multiple places. See TclAttemptAllocElemsEx and similar for usage
|
| ︙ | ︙ | |||
3136 3137 3138 3139 3140 3141 3142 | MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ | | | | | | | | | 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 | MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType *tclBignumTypePtr; MODULE_SCOPE const Tcl_ObjType *tclBooleanTypePtr; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE Tcl_ObjType *tclDictTypePtr; MODULE_SCOPE const Tcl_ObjType *tclDoubleTypePtr; MODULE_SCOPE const Tcl_ObjType tclExprCodeType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType *tclIntTypePtr; MODULE_SCOPE Tcl_ObjType *tclListTypePtr; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; /* |
| ︙ | ︙ | |||
3247 3248 3249 3250 3251 3252 3253 |
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
Tcl_Size word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
| | | | 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
Tcl_Obj *body; /* Loop body. */
Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
const char *msg; /* Error message part. */
Tcl_Size word; /* Index of the body script in the command */
} ForIterData;
/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
* and Tcl_FindSymbol. This structure corresponds to an opaque
* typedef in tcl.h */
typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
const char* symbol);
struct Tcl_LoadHandle_ {
void *clientData; /* Client data is the load handle in the
* native filesystem if a module was loaded
* there, or an opaque pointer to a structure
|
| ︙ | ︙ | |||
3283 3284 3285 3286 3287 3288 3289 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ | < > | | 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 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, int loc); MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE void TclAppendUtfToUtf(Tcl_Obj *objPtr, const char *bytes, Tcl_Size numBytes); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], Tcl_Size objc, CmdFrame *cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], Tcl_Size objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], Tcl_Size objc, void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd, Tcl_Size pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE void TclArithSeriesInit(void); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, void *clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, Tcl_Size strLen, const unsigned char *pattern, Tcl_Size ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckEmptyString(Tcl_Interp *interp, Tcl_Obj *objPtr, int *res); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE int TclChanIsBinary(Tcl_Channel chan); MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); |
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 | Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); | | > > < > | 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 | Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, const char *name, Tcl_Namespace *nameNamespacePtr, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE void TclDictInit(void); MODULE_SCOPE Tcl_Obj* TclDuplicatePureObj(Tcl_Interp *interp, Tcl_Obj * objPtr, const Tcl_ObjType *typPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *literalPtr); MODULE_SCOPE int TclDictGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj **valuePtrPtr); MODULE_SCOPE Tcl_Obj * TclDictObjSmartRef(Tcl_Interp *interp, Tcl_Obj *); MODULE_SCOPE int TclDictPut(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, Tcl_Obj *valuePtr); MODULE_SCOPE int TclDictPutString(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key, const char *value); MODULE_SCOPE int TclDictRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key); /* TIP #280 - Modified token based evaluation, with line information. */ |
| ︙ | ︙ | |||
3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 | MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *prefix); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE size_t TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; | > > | 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 | MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, Tcl_Size *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *prefix); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclIndexIsFromEnd(Tcl_Size encoded); MODULE_SCOPE Tcl_Size TclIndexLast (Tcl_Size N); MODULE_SCOPE int TclCompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE size_t TclHashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; |
| ︙ | ︙ | |||
3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 | MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[]); MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, Tcl_Size *lines, Tcl_Obj *const *elems); | > > > | > | | > | < | > > > > > > | > | 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 | MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_ObjInterfaceListLengthProc TclLengthOne; MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[]); MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index); MODULE_SCOPE int Tcl_LengthIsFinite(Tcl_Size length); MODULE_SCOPE void TclListInit(void); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, Tcl_Size *lines, Tcl_Obj *const *elems); MODULE_SCOPE int (*TclObjInterfaceGetListIndex (Tcl_Obj *objPtr)) (tclObjTypeInterfaceArgsListIndex); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, Tcl_Obj *toObj, Tcl_Size elemCount, Tcl_Obj *const elemObjv[]); MODULE_SCOPE int TclListObjRange(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **resultPtr); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE int TclLsetFlat(tclObjTypeInterfaceArgsListSetDeep); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE Tcl_Obj * TclNewNamespaceObj(Tcl_Namespace *namespacePtr); MODULE_SCOPE Tcl_Obj * TclObjGetScalar(Tcl_Obj *objPtr); MODULE_SCOPE ObjInterface * TclObjInterface(Tcl_Obj *objPtr); MODULE_SCOPE const char * TclObjTypeName(const Tcl_ObjType *typePtr); MODULE_SCOPE int TclObjTypeVersion (const Tcl_ObjType *typePtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, Tcl_Size numBytes, Tcl_Parse *parsePtr); MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE void TclProcInit(void); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_Interp *interp, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, Tcl_Size len); MODULE_SCOPE int TclSetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void * TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); |
| ︙ | ︙ | |||
3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 | Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE void *TclpGetNativeCwd(void *clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, | > | 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 | Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE void *TclpGetNativeCwd(void *clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE void Tcl_ObjTypeVersion(Tcl_Obj *objPtr, int *version); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); MODULE_SCOPE void * TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, |
| ︙ | ︙ | |||
3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 | Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, TCL_HASH_TYPE numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, int nocase, Tcl_Size reqlength); MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, int flags, Tcl_Size line, struct CompileEnv *envPtr); | > > | 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 | Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, TCL_HASH_TYPE numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, int nocase, Tcl_Size reqlength); MODULE_SCOPE int TclStringIndexInterface(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *indexPtr, Tcl_Obj **charPtr); MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, int flags, Tcl_Size line, struct CompileEnv *envPtr); |
| ︙ | ︙ | |||
3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 | MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE int TclObjInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, | > | 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 | MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE int TclObjInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(void *clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, |
| ︙ | ︙ | |||
3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( | > | 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 | MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockClassicInit(Tcl_Interp *interp); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( |
| ︙ | ︙ | |||
4150 4151 4152 4153 4154 4155 4156 | /* * Error message utility functions */ MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); | < < | 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 | /* * Error message utility functions */ MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) #define TCL_INDEX_START ((Tcl_Size)0) /* *---------------------------------------------------------------------- * |
| ︙ | ︙ | |||
4320 4321 4322 4323 4324 4325 4326 | * * Note that the optimiser should resolve the case (interp==NULL) at compile * time. */ # define ALLOC_NOBJHIGH 1200 | | | | > | | 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 |
*
* Note that the optimiser should resolve the case (interp==NULL) at compile
* time.
*/
# define ALLOC_NOBJHIGH 1200
# define TclAllocObjStorageEx(interp, objPtr) \
do { \
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *) (interp))->allocCache), \
(cachePtr->numObjects == 0))) { \
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
cachePtr->firstObjPtr = (Tcl_Obj *) \
(objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *)(interp))->allocCache), \
((cachePtr->numObjects == 0) || \
(cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \
TclThreadFreeObj(objPtr); \
|
| ︙ | ︙ | |||
4389 4390 4391 4392 4393 4394 4395 | #endif #else /* TCL_MEM_DEBUG */ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, int line); # define TclDbNewObj(objPtr, file, line) \ | | | 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 |
#endif
#else /* TCL_MEM_DEBUG */
MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
int line);
# define TclDbNewObj(objPtr, file, line) \
do { \
TclIncrObjsAllocated(); \
(objPtr) = (Tcl_Obj *) \
Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
TclDbInitNewObj((objPtr), (file), (line)); \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
|
| ︙ | ︙ | |||
4433 4434 4435 4436 4437 4438 4439 |
*
*----------------------------------------------------------------
*/
#define TclInitEmptyStringRep(objPtr) \
((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
| | | > | > | | 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 |
*
*----------------------------------------------------------------
*/
#define TclInitEmptyStringRep(objPtr) \
((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
TclInitEmptyStringRep(objPtr); \
} else { \
(objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \
memcpy((objPtr)->bytes, (bytePtr) \
? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
((((len) == 0) ? ( \
TclInitEmptyStringRep(objPtr) \
) : ( \
(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \
(objPtr)->length = ((objPtr)->bytes) ? \
(memcpy((objPtr)->bytes, (bytePtr) \
? (bytePtr) : &tclEmptyString, (len)), \
(objPtr)->bytes[len] = '\0', (len)) : (-1) \
)), (objPtr)->bytes)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
* pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
* macro's expression result is the string rep's byte pointer which might be
* NULL. The bytes referenced by this pointer must not be modified by the
* caller. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
: (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
|
| ︙ | ︙ | |||
4502 4503 4504 4505 4506 4507 4508 |
*
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
do { \
| | | 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 |
*
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
do { \
Tcl_Obj *_isobjPtr = (Tcl_Obj *) (objPtr); \
if (_isobjPtr->bytes != NULL) { \
if (_isobjPtr->bytes != &tclEmptyString) { \
Tcl_Free((char *)_isobjPtr->bytes); \
} \
_isobjPtr->bytes = NULL; \
} \
} while (0)
|
| ︙ | ︙ | |||
4684 4685 4686 4687 4688 4689 4690 | * * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #define TclIsPureDict(objPtr) \ | | | | 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 |
*
* MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
(((objPtr)->bytes==NULL) && TclHasInternalRep((objPtr), tclDictTypePtr))
#define TclHasInternalRep(objPtr, type) \
((objPtr)->typePtr == (void *)(type))
#define TclFetchInternalRep(objPtr, type) \
(TclHasInternalRep((objPtr), (type)) ? &(objPtr)->internalRep : NULL)
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to increment a namespace's export epoch
* counter. The ANSI C "prototype" for this macro is:
|
| ︙ | ︙ | |||
4732 4733 4734 4735 4736 4737 4738 | */ MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; | | | > | 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 | */ MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; MODULE_SCOPE Tcl_LibraryInitProc TcltestObjectInterfaceInit; MODULE_SCOPE Tcl_LibraryInitProc TcltestObjectInterfaceListIntegerInit; MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters * special to [string match]. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclMatchIsTrivial(const char *pattern); *---------------------------------------------------------------- |
| ︙ | ︙ | |||
4763 4764 4765 4766 4767 4768 4769 |
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
| | | | | | | | | | 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 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 |
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, tclIntTypePtr, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
do { \
Tcl_ObjInternalRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, tclDoubleTypePtr, &ir); \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, * Tcl_Size len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = tclIntTypePtr; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewUIntObj(objPtr, uw) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
Tcl_WideUInt uw_ = (uw); \
if (uw_ > WIDE_MAX) { \
mp_int bignumValue_; \
if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \
Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
} \
TclSetBignumInternalRep((objPtr), &bignumValue_); \
} else { \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
(objPtr)->typePtr = tclIntTypePtr; \
} \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewIndexObj(objPtr, uw)\
TclNewIntObj(objPtr, uw)
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.doubleValue = (double)(d); \
(objPtr)->typePtr = tclDoubleTypePtr; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewStringObj(objPtr, s, len) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
|
| ︙ | ︙ | |||
4912 4913 4914 4915 4916 4917 4918 | /* *---------------------------------------------------------------- * Inline version of TclCleanupCommand; still need the function as it is in * the internal stubs, but the core can use the macro instead. */ | | | | | | | 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 |
/*
*----------------------------------------------------------------
* Inline version of TclCleanupCommand; still need the function as it is in
* the internal stubs, but the core can use the macro instead.
*/
#define TclCleanupCommandMacro(cmdPtr) \
do { \
if ((cmdPtr)->refCount-- <= 1) { \
Tcl_Free(cmdPtr); \
} \
} while (0)
/*
* inside this routine crement refCount first incase cmdPtr is replacing itself
*/
#define TclRoutineAssign(location, cmdPtr) \
do { \
|
| ︙ | ︙ | |||
5002 5003 5004 5005 5006 5007 5008 |
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
*(void **)&(memPtr) = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
| | | | 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 |
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
*(void **)&(memPtr) = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
TclIncrObjsFreed(); \
} while (0)
#else /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
*(void **)&(memPtr) = (void *)_objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
Tcl_Obj *_objPtr = (Tcl_Obj *) (memPtr); \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
_objPtr->refCount = 1; \
TclDecrRefCount(_objPtr); \
} while (0)
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
5091 5092 5093 5094 5095 5096 5097 |
#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) \
| | | 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 |
#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) = (Tcl_Alloc(sizeof(NRE_callback))))
#define TCLNR_FREE(interp, ptr) Tcl_Free(ptr)
#endif
#if NRE_ENABLE_ASSERTS
#define NRE_ASSERT(expr) assert((expr))
#else
#define NRE_ASSERT(expr)
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. */ #ifndef _TCLINTDECLS #define _TCLINTDECLS #undef TCL_STORAGE_CLASS |
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 | #if defined(USE_TCL_STUBS) #undef Tcl_StaticLibrary #define Tcl_StaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ | < < < < < < < < < < < | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 | #if defined(USE_TCL_STUBS) #undef Tcl_StaticLibrary #define Tcl_StaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ #undef TclUnusedStubEntry #define TclObjInterpProc TclGetObjInterpProc() #define TclObjInterpProc2 TclGetObjInterpProc2() #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ |
1 2 3 4 5 6 7 | /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. | > > > > > > > > > > > > > > < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | /* * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | /* * 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. */ | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
/*
* 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.
*/
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
extern "C" {
#endif
/*
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 | (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ | < > > > > > > > > > | 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 | (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #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 #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #ifdef MAC_OSX_TCL /* not accessible on Win32/UNIX */ MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 16 */ MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
| ︙ | ︙ | |||
715 716 717 718 719 720 721 | #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) | < < < | < | | | | | | < | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt # undef TclWinGetPlatformId # undef TclWinResetInterfaces # undef TclWinSetInterfaces #else # undef TclpGetPid # define TclpGetPid(pid) ((size_t)(pid)) #endif #endif /* _TCLINTPLATDECLS */ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. */ #include "tclInt.h" /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the function below. */ |
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit",
"share",
| < < < < | 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 |
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit",
"share",
"slaves",
"target", "transfer", NULL
};
static const char *const optionsNoSlaves[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
"eval", "exists", "expose",
"hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
"share", "target", "transfer",
NULL
};
enum interpOptionEnum {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE,
OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID,
OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE,
OPT_SLAVES,
OPT_TARGET, OPT_TRANSFER
} index;
Tcl_Size i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
}
if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
| | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
}
if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 4, objc, objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv);
default:
Tcl_Panic("unreachable");
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 |
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
| < < | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
return TCL_ERROR;
}
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
case OPT_SLAVES:
case OPT_CHILDREN: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hashSearch;
char *string;
|
| ︙ | ︙ | |||
2670 2671 2672 2673 2674 2675 2676 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
| | | 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 |
}
if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
&limitType) != TCL_OK) {
return TCL_ERROR;
}
switch (limitType) {
case LIMIT_TYPE_COMMANDS:
return ChildCommandLimitCmd(interp, childInterp, 3, objc, objv);
case LIMIT_TYPE_TIME:
return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 2) {
|
| ︙ | ︙ | |||
4543 4544 4545 4546 4547 4548 4549 |
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
| | | | 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 |
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) Tcl_GetStringFromObj(scriptObj, &scriptLen);
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", (char *)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) {
|
| ︙ | ︙ | |||
4747 4748 4749 4750 4751 4752 4753 |
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
| | | | | 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 |
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
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", (char *)NULL);
return TCL_ERROR;
}
break;
case OPT_MILLI:
milliObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"milliseconds must be non-negative", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"BADVALUE", (char *)NULL);
return TCL_ERROR;
}
limitMoment.usec = tmp*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
(void) Tcl_GetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
}
if (tmp < 0) {
|
| ︙ | ︙ |
1 | /* | < < < < < < < > > > > > > > > > | 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 © 1993 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2008 Rene Zaumseil * Copyright © 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLink.c -- * * This file implements linked variables (a C variable that is tied to a * Tcl variable). The idea of linked variables was first suggested by * Andreas Stolcke and this implementation is based heavily on a * prototype implementation provided by him. */ #include "tclInt.h" #include "tclTomMath.h" #include <math.h> /* * For each linked variable there is a data structure of the following type, * which describes the link and is the clientData for the trace set on the Tcl |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
void *addr; /* Location of C variable. */
Tcl_Size bytes; /* Size of C variable array. This is 0 when
* single variables, and >0 used for array
* variables. */
| | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
void *addr; /* Location of C variable. */
Tcl_Size bytes; /* Size of C variable array. This is 0 when
* single variables, and >0 used for array
* variables. */
Tcl_Size numElems; /* Number of elements in C variable array.
* Zero for single variables. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
char c;
unsigned char uc;
int i;
unsigned int ui;
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
Tcl_Obj *objPtr);
/*
* A marker type used to flag weirdnesses so we can pass them around right.
*/
static const Tcl_ObjType invalidRealType = {
| | < > | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
Tcl_Obj *objPtr);
/*
* A marker type used to flag weirdnesses so we can pass them around right.
*/
static const Tcl_ObjType invalidRealType = {
"invalidReal", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
* Convenience macro for accessing the value of the C variable pointed to by a
* link. Note that this macro produces something that may be regarded as an
* lvalue or rvalue; it may be assigned to as well as read. Also note that
* this macro assumes the name of the variable being accessed (linkPtr); this
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
case TCL_LINK_STRING:
linkPtr->bytes = size * sizeof(char);
size = 1; /* This is a variable length string, no need
* to check last value. */
/*
* If no address is given create one and use as address the
| | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
case TCL_LINK_STRING:
linkPtr->bytes = size * sizeof(char);
size = 1; /* This is a variable length string, no need
* to check last value. */
/*
* If no address is given create one and use as address the
* not needed linkPtr->lastValue
*/
if (addr == NULL) {
linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
addr = (char *) &linkPtr->lastValue.cPtr;
}
|
| ︙ | ︙ | |||
519 520 521 522 523 524 525 |
Tcl_Obj *objPtr,
double *dblPtr)
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
Tcl_Obj *objPtr,
double *dblPtr)
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, tclDoubleTypePtr);
if (irPtr != NULL) {
*dblPtr = irPtr->doubleValue;
return 0;
}
#endif /* ACCEPT_NAN */
return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
Tcl_Size length;
| | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 |
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
Tcl_Size length;
str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
Tcl_Size length;
| | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
Tcl_Size length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 0) || ((length == 2) && (str[0] == '0')
&& strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 | * modification. * *---------------------------------------------------------------------- */ static char * LinkTraceProc( | | | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
* modification.
*
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
void *clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
/* Links can only be made to global variables,
* so we can find them with need to resolve
* caller-supplied name in caller context. */
int flags) /* Miscellaneous additional information. */
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
*/
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "linked variable is read-only";
}
| | | | | 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 |
*/
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName, NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
return (char *) "internal error: linked variable couldn't be read";
}
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
pp = (char **) linkPtr->addr;
*pp = (char *)Tcl_Realloc(*pp, ++valueLength);
memcpy(*pp, value, valueLength);
return NULL;
case TCL_LINK_CHARS:
value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, valueLength);
memcpy(linkPtr->addr, value, valueLength);
|
| ︙ | ︙ | |||
887 888 889 890 891 892 893 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i = 0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (GetInt(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i = 0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (GetInt(objv[i], varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have integer values";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (GetInt(valueObj, varPtr)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | | | | 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 |
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
int *varPtr = &linkPtr->lastValue.iPtr[i];
if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have boolean value";
}
}
} else {
int *varPtr = &linkPtr->lastValue.i;
if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
}
LinkedVar(int) = *varPtr;
}
break;
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have char value";
}
linkPtr->lastValue.cPtr[i] = (char) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt;
}
break;
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, (int)UCHAR_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned char value";
}
linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt;
}
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | | | 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 |
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have short value";
}
linkPtr->lastValue.sPtr[i] = (short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(SHRT_MIN, valueInt, SHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have short value";
}
LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt;
}
break;
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetInt(objv[i], &valueInt)
|| !InRange(0, valueInt, (int)USHRT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned short value";
}
linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt;
}
} else {
if (GetInt(valueObj, &valueInt)
|| !InRange(0, valueInt, (int)USHRT_MAX)) {
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 |
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 |
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetWide(objv[i], &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned int value";
}
linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide;
}
} else {
if (GetWide(valueObj, &valueWide)
|| !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) {
|
| ︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 |
break;
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
| | | | | 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 |
break;
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned wide int value";
}
linkPtr->lastValue.uwPtr[i] = valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide;
}
break;
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetDouble(objv[i], &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable array must have float value";
}
linkPtr->lastValue.fPtr[i] = (float) valueDouble;
}
} else {
if (GetDouble(valueObj, &valueDouble)
&& !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX)
&& !IsSpecial(valueDouble)) {
|
| ︙ | ︙ |
1 2 3 4 5 | /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * | > > > > > > > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | /* * Copyright © 2022 Ashok P. Nadkarni. All rights reserved. * Copyright © 2021 - 2024 Nathan Coulter. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * */ #include <assert.h> #include "tclInt.h" #include "tclTomMath.h" /* |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | # ifndef NDEBUG # define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */ # endif #endif #ifdef ENABLE_LIST_ASSERTS | | | | | | | | | | | | | | | | > | | 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 |
# ifndef NDEBUG
# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */
# endif
#endif
#ifdef ENABLE_LIST_ASSERTS
#define LIST_ASSERT(cond) assert(cond)
/*
* LIST_INDEX_ASSERT is to catch errors with negative indices and counts
* being passed AFTER validation. On Tcl9 length types are unsigned hence
* the checks against LIST_MAX. On Tcl8 length types are signed hence the
* also checks against 0.
*/
#define LIST_INDEX_ASSERT(idxarg) \
do { \
Tcl_Size idx_ = (idxarg); /* To guard against ++ etc. */ \
LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \
} while (0)
/* Ditto for counts except upper limit is different */
#define LIST_COUNT_ASSERT(countarg) \
do { \
Tcl_Size count_ = (countarg); /* To guard against ++ etc. */ \
LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \
} while (0)
#else
#define LIST_ASSERT(cond) ((void) 0)
#define LIST_INDEX_ASSERT(idx) ((void) 0)
#define LIST_COUNT_ASSERT(count) ((void) 0)
#endif
/* Checks for when caller should have already converted to internal list type */
#define LIST_ASSERT_TYPE(listObj) \
LIST_ASSERT(TclHasInternalRep((listObj), tclListTypePtr))
/*
* If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
* command line), the entire list internal representation is checked for
* inconsistencies. This has a non-trivial cost so has to be separately
* enabled and not part of assertions checking. However, the test suite does
* invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS.
*/
#ifdef ENABLE_LIST_INVARIANTS
#define LISTREP_CHECK(listRepPtr) \
ListRepValidate(listRepPtr, __FILE__, __LINE__)
#else
#define LISTREP_CHECK(listRepPtr) (void) 0
#endif
/*
* Flags used for controlling behavior of allocation of list
* internal representations.
*
* If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
*/
#define LISTREP_PANIC_ON_FAIL 0x00000001
#define LISTREP_SPACE_FAVOR_FRONT 0x00000002
#define LISTREP_SPACE_FAVOR_BACK 0x00000004
#define LISTREP_SPACE_ONLY_BACK 0x00000008
#define LISTREP_SPACE_FAVOR_NONE \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
| | | < | < | > | < < < | | > | > > > > > > > > > > | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < | | | | > | | | | | | | | | | | | | | | | | | | | | | 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 |
*/
#define LISTREP_PANIC_ON_FAIL 0x00000001
#define LISTREP_SPACE_FAVOR_FRONT 0x00000002
#define LISTREP_SPACE_FAVOR_BACK 0x00000004
#define LISTREP_SPACE_ONLY_BACK 0x00000008
#define LISTREP_SPACE_FAVOR_NONE \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
#define LISTREP_SPACE_FLAGS \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
| LISTREP_SPACE_ONLY_BACK)
/*
* Prototypes for non-inline static functions defined later in this file:
*/
static int MemoryAllocationError(Tcl_Interp *, size_t size);
static int ListLimitExceededError(Tcl_Interp *);
static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags);
static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *);
static int ListRepInitAttempt(Tcl_Interp *, Tcl_Size objc,
Tcl_Obj *const objv[], ListRep *);
static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);
static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr
, ListRep *repPtr);
static void ListRepRange(ListRep *srcRepPtr, Tcl_Size fromIdx,
Tcl_Size toIdx, int preserveSrcRep, ListRep *rangeRepPtr);
static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots);
static void ListRepValidate(const ListRep *repPtr, const char *file,
int lineNum);
static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeListInternalRep(Tcl_Obj *listPtr);
int TclSetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfList(Tcl_Obj *listPtr);
static int ListObjAppendElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *objPtr);
static int ListObjAppendList(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *elemListPtr);
static int ListObjIndex(tclObjTypeInterfaceArgsListIndex);
static int ListObjInterfaceGetElements(tclObjTypeInterfaceArgsListAll);
static int ListObjInterfaceLength(tclObjTypeInterfaceArgsListLength);
static int ListObjSetElement(tclObjTypeInterfaceArgsListSet);
static int LsetFlat(tclObjTypeInterfaceArgsListSetDeep);
static int ListObjRange(tclObjTypeInterfaceArgsListRange);
static int ListObjReplace(tclObjTypeInterfaceArgsListReplace);
static int ListObjStringIsEmpty(tclObjTypeInterfaceArgsStringIsEmpty);
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
*
* The internal representation of a list object is ListRep defined in tcl.h.
*/
static ObjectType tclListObjectType = {
"list",
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
TclSetListFromAny, /* setFromAnyProc */
2,
NULL
};
Tcl_ObjType * tclListTypePtr = (Tcl_ObjType *)&tclListObjectType;
void TclListInit(void) {
Tcl_ObjInterface *oiPtr;
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnStringIsEmpty(oiPtr ,ListObjStringIsEmpty);
Tcl_ObjInterfaceSetFnListAll(oiPtr ,ListObjInterfaceGetElements);
Tcl_ObjInterfaceSetFnListAppend(oiPtr ,ListObjAppendElement);
Tcl_ObjInterfaceSetFnListAppendList(oiPtr ,ListObjAppendList);
Tcl_ObjInterfaceSetFnListIndex(oiPtr ,ListObjIndex);
Tcl_ObjInterfaceSetFnListLength(oiPtr ,ListObjInterfaceLength);
Tcl_ObjInterfaceSetFnListRange(oiPtr ,ListObjRange);
Tcl_ObjInterfaceSetFnListReplace(oiPtr ,ListObjReplace);
Tcl_ObjInterfaceSetFnListSet(oiPtr ,ListObjSetElement);
Tcl_ObjInterfaceSetFnListSetDeep(oiPtr ,LsetFlat);
Tcl_ObjTypeSetInterface(tclListTypePtr ,oiPtr);
return;
}
/* Macros to manipulate the List internal rep */
#define ListSetIntRep(objPtr, listRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (listRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
(listRepPtr)->refCount++; \
Tcl_StoreInternalRep((objPtr), tclListTypePtr, &ir); \
} while (0)
#define ListGetIntRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), tclListTypePtr); \
(listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define ListResetIntRep(objPtr, listRepPtr) \
TclFetchInternalRep((objPtr), tclListTypePtr)->twoPtrValue.ptr1 = (listRepPtr)
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
#define ListRepIncrRefs(repPtr) \
do { \
(repPtr)->storePtr->refCount++; \
if ((repPtr)->spanPtr) \
(repPtr)->spanPtr->refCount++; \
} while (0)
/* Returns number of free unused slots at the back of the ListRep's ListStore */
#define ListRepNumFreeTail(repPtr) \
((repPtr)->storePtr->numAllocated \
- ((repPtr)->storePtr->firstUsed + (repPtr)->storePtr->numUsed))
/* Returns number of free unused slots at the front of the ListRep's ListStore */
#define ListRepNumFreeHead(repPtr) \
((repPtr)->storePtr->firstUsed)
/* Returns a pointer to the slot corresponding to list index listIdx */
#define ListRepSlotPtr(repPtr, listIdx) \
(&(repPtr)->storePtr->slots[ListRepStart(repPtr) + (listIdx)])
/*
* Macros to replace the internal representation in a Tcl_Obj. There are
* subtle differences in each so make sure to use the right one to avoid
* memory leaks, access to freed memory and the like.
*
* ListObjStompRep - assumes the Tcl_Obj internal representation can be
* overwritten AND that the passed ListRep already has reference counts that
* include the reference from the Tcl_Obj. Basically just copies the pointers
* and sets the internal Tcl_Obj type to list
*
* ListObjOverwriteRep - like ListObjOverwriteRep but additionally
* increments reference counts on the passed ListRep. Generally used when
* the string representation of the Tcl_Obj is not to be modified.
*
* ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally
* assumes the Tcl_Obj internal rep is valid (and possibly even same as
* passed ListRep) and frees it first. Additionally invalidates the string
* representation. Generally used when modifying a Tcl_Obj value.
*/
#define ListObjStompRep(objPtr, repPtr) \
do { \
(objPtr)->internalRep.twoPtrValue.ptr1 = (repPtr)->storePtr; \
(objPtr)->internalRep.twoPtrValue.ptr2 = (repPtr)->spanPtr; \
(objPtr)->typePtr = tclListTypePtr; \
} while (0)
#define ListObjOverwriteRep(objPtr, repPtr_) \
do { \
ListRepIncrRefs(repPtr_); \
ListObjStompRep(objPtr, repPtr_); \
} while (0)
#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \
do { \
/* Note order important, don't use ListObjOverwriteRep! */ \
ListRepIncrRefs(repPtr_); \
TclFreeInternalRep(objPtr_); \
TclInvalidateStringRep(objPtr_); \
ListObjStompRep(objPtr_, repPtr_); \
} while (0)
/*
*------------------------------------------------------------------------
*
* ListSpanNew --
*
* Allocates and initializes memory for a new ListSpan. The reference
* count on the returned struct is 0.
*
* Results:
* Non-NULL pointer to the allocated ListSpan.
*
* Side effects:
* The function will panic on memory allocation failure.
*
*------------------------------------------------------------------------
*/
static inline ListSpan *
ListSpanNew(
Tcl_Size firstSlot, /* Starting slot index of the span */
Tcl_Size numSlots) /* Number of slots covered by the span */
{
ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr));
spanPtr->refCount = 0;
spanPtr->spanStart = firstSlot;
spanPtr->spanLength = numSlots;
return spanPtr;
}
|
| ︙ | ︙ | |||
294 295 296 297 298 299 300 | * Side effects: * None. * *------------------------------------------------------------------------ */ static inline int ListSpanMerited( | | | | > | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static inline int
ListSpanMerited(
Tcl_Size length, /* Length of the proposed span. */
Tcl_Size usedStorageLength, /* Number of slots currently in use. */
Tcl_Size allocatedStorageLength)
/* Length of the current allocation. */
{
/*
* Possible optimizations for future consideration
* - heuristic LIST_SPAN_THRESHOLD
* - currently, information about the sharing (ref count) of existing
* storage is not passed. Perhaps it should be. For example if the
* existing storage has a "large" ref count, then it might make sense
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayIncrRefs( | | | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 |
* Side effects:
* As above.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayIncrRefs(
Tcl_Obj *const *objv, /* Pointer to the array */
Tcl_Size startIdx, /* Starting index of subarray within objv */
Tcl_Size count) /* Number of elements in the subarray */
{
Tcl_Obj *const *end;
LIST_INDEX_ASSERT(startIdx);
LIST_COUNT_ASSERT(count);
objv += startIdx;
end = objv + count;
while (objv < end) {
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | * Side effects: * As above. * *------------------------------------------------------------------------ */ static inline void ObjArrayDecrRefs( | | | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
* Side effects:
* As above.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayDecrRefs(
Tcl_Obj *const *objv, /* Pointer to the array */
Tcl_Size startIdx, /* Starting index of subarray within objv */
Tcl_Size count) /* Number of elements in the subarray */
{
Tcl_Obj * const *end;
LIST_INDEX_ASSERT(startIdx);
LIST_COUNT_ASSERT(count);
objv += startIdx;
end = objv + count;
while (objv < end) {
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 | * Side effects: * Reference counts on copied Tcl_Obj's are incremented. * *------------------------------------------------------------------------ */ static inline void ObjArrayCopy( | | | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
* Side effects:
* Reference counts on copied Tcl_Obj's are incremented.
*
*------------------------------------------------------------------------
*/
static inline void
ObjArrayCopy(
Tcl_Obj **to, /* Destination */
Tcl_Size count, /* Number of pointers to copy */
Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */
{
Tcl_Obj **end;
LIST_COUNT_ASSERT(count);
end = to + count;
/* TODO - would memmove followed by separate IncrRef loop be faster? */
while (to < end) {
Tcl_IncrRefCount(*from);
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 | * Side effects: * Error message and code are stored in the interpreter if not NULL. * *------------------------------------------------------------------------ */ static int MemoryAllocationError( | | | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
* Side effects:
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
size_t size) /* Size of attempted allocation that failed */
{
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list construction failed: unable to alloc %" TCL_Z_MODIFIER
"u bytes",
size));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
int lineNum)
{
ListStore *storePtr = repPtr->storePtr;
const char *condition;
(void)storePtr; /* To stop gcc from whining about unused vars */
| | | | | | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
int lineNum)
{
ListStore *storePtr = repPtr->storePtr;
const char *condition;
(void)storePtr; /* To stop gcc from whining about unused vars */
#define INVARIANT(cond) \
do { \
if (!(cond)) { \
condition = #cond; \
goto failure; \
} \
} while (0)
/* Separate each condition so line number gives exact reason for failure */
INVARIANT(storePtr != NULL);
INVARIANT(storePtr->numAllocated >= 0);
INVARIANT(storePtr->numAllocated <= LIST_MAX);
INVARIANT(storePtr->firstUsed >= 0);
|
| ︙ | ︙ | |||
672 673 674 675 676 677 678 |
#undef INVARIANT
return;
failure:
Tcl_Panic("List internal failure in %s line %d. Condition: %s",
| < < | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
#undef INVARIANT
return;
failure:
Tcl_Panic("List internal failure in %s line %d. Condition: %s",
file, lineNum, condition);
}
/*
*------------------------------------------------------------------------
*
* TclListObjValidate --
*
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 | * ListStoreNew -- * * Allocates a new ListStore with space for at least objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values * in that array. If objv==NULL, initalize 0 elements, with space * to add objc more. * | | | | | | | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 | * ListStoreNew -- * * Allocates a new ListStore with space for at least objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values * in that array. If objv==NULL, initalize 0 elements, with space * to add objc more. * * Normally the function allocates the exact space requested unless * the flags arguments has any LISTREP_SPACE_* * bits set. See the comments for those #defines. * * Results: * On success, a pointer to the allocated ListStore is returned. * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in * flags; otherwise returns NULL. * * Side effects: * The ref counts of the elements in objv are incremented on success * since the returned ListStore references them. * *---------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
847 848 849 850 851 852 853 | } /* *---------------------------------------------------------------------- * * ListRepInit -- * | | | | | | | | | | 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 | } /* *---------------------------------------------------------------------- * * ListRepInit -- * * Initializes a ListRep to hold a list internal representation * with space for objc elements. * * objc must be > 0. If objv!=NULL, initializes with the first objc * values in that array. If objv==NULL, initalize list internal rep to * have 0 elements, with space to add objc more. * * Normally the function allocates the exact space requested unless * the flags arguments has one of the LISTREP_SPACE_* bits set. * See the comments for those #defines. * * The reference counts of the ListStore and ListSpan (if present) * pointed to by the initialized repPtr are set to zero. * Caller has to manage them as necessary. * * Results: * On success, TCL_OK is returned with *listRepPtr initialized. * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise * returns TCL_ERROR with *listRepPtr fields set to NULL. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
912 913 914 915 916 917 918 | * ListRepInitAttempt -- * * Creates a list internal rep with space for objc elements. See * ListRepInit for requirements for parameters (in particular objc must * be > 0). This function only adds error messages to the interpreter if * not NULL. * | | | | 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 | * ListRepInitAttempt -- * * Creates a list internal rep with space for objc elements. See * ListRepInit for requirements for parameters (in particular objc must * be > 0). This function only adds error messages to the interpreter if * not NULL. * * The reference counts of the ListStore and ListSpan (if present) * pointed to by the initialized repPtr are set to zero. * Caller has to manage them as necessary. * * Results: * On success, TCL_OK is returned with *listRepPtr initialized. * On allocation failure, returnes TCL_ERROR with an error message * in the interpreter if non-NULL. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * |
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 | * refer to a list object and the object can not be converted to one, * TCL_ERROR is returned and an error message will be left in the * interpreter's result if interp is not NULL. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. *repPtr is initialized to the internal rep | | | | | | | 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 |
* refer to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in the
* interpreter's result if interp is not NULL.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object. *repPtr is initialized to the internal rep
* if result is TCL_OK, or set to NULL on error.
*----------------------------------------------------------------------
*/
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
if (!TclHasInternalRep(listPtr, tclListTypePtr)) {
int result;
result = TclSetListFromAny(interp, listPtr);
if (result != TCL_OK) {
/* Init to keep gcc happy wrt uninitialized fields at call site */
repPtr->storePtr = NULL;
repPtr->spanPtr = NULL;
return result;
}
}
ListObjGetRep(listPtr, repPtr);
LISTREP_CHECK(repPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
TclFreeInternalRep(objPtr);
TclInvalidateStringRep(objPtr);
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 |
ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
TclFreeInternalRep(objPtr);
TclInvalidateStringRep(objPtr);
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
/*
*------------------------------------------------------------------------
*
* ListRepRange --
*
* Initializes a ListRep as a range within the passed ListRep.
* The range limits are clamped to the list boundaries.
*
* Results:
* None.
*
* Side effects:
* The ListStore and ListSpan referenced by in the returned ListRep
* may or may not be the same as those passed in. For example, the
* ListStore may differ because the range is small enough that a new
* ListStore is more memory-optimal. The ListSpan may differ because
* it is NULL or shared. Regardless, reference counts on the returned
* values are not incremented. Generally, ListObjReplaceRepAndInvalidate
* may be used to store the new ListRep back into an object or a
* ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors.
* Any other use should be carefully reconsidered.
* TODO WARNING:- this is an awkward interface and easy for caller
* to get wrong. Mostly due to refcount combinations. Perhaps passing
* in the source listObj instead of source listRep might simplify.
*
*------------------------------------------------------------------------
*/
static void
ListRepRange(
ListRep *srcRepPtr, /* Contains source of the range */
Tcl_Size fromIdx, /* Index of first element to include */
Tcl_Size toIdx, /* Index of last element to include */
int preserveSrcRep, /* If true, srcRepPtr contents must not be
* modified (generally because a shared Tcl_Obj
* references it) */
ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
{
Tcl_Obj **srcElems;
Tcl_Size numSrcElems = ListRepLength(srcRepPtr);
Tcl_Size rangeLen;
Tcl_Size numAfterRangeEnd;
LISTREP_CHECK(srcRepPtr);
/* Take the opportunity to garbage collect */
/* TODO - we probably do not need the preserveSrcRep here unlike later */
if (!preserveSrcRep) {
/* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
ListRepFreeUnreferenced(srcRepPtr);
} /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= numSrcElems) {
toIdx = numSrcElems - 1;
}
if (fromIdx > toIdx) {
/* Empty list of capacity 1. */
ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
return;
}
rangeLen = toIdx - fromIdx + 1;
/*
* We can create a range one of four ways:
* (0) Range encapsulates entire list
* (1) Special case: deleting in-place from end of an unshared object
* (2) Use a ListSpan referencing the current ListStore
* (3) Creating a new ListStore
* (4) Removing all elements outside the range in the current ListStore
* Option (4) may only be done if caller has not disallowed it AND
* the ListStore is not shared.
*
* The choice depends on heuristics related to speed and memory.
* TODO - heuristics below need to be measured and tuned.
*
* Note: Even if nothing below cause any changes, we still want the
* string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
* be returned as is even if the range encompasses the whole list.
*/
if (fromIdx == 0 && toIdx == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
/* T:listrep-1.10.1,2.8.1 */
*rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
} else if (fromIdx == 0 && (!preserveSrcRep)
&& (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
/* Option 1 - Special case unshared, exclude end elements, no span */
LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
numAfterRangeEnd = numSrcElems - (toIdx + 1);
/* Assert: Because numSrcElems > toIdx earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-1.{8,9} */
ObjArrayDecrRefs(srcElems, toIdx + 1, numAfterRangeEnd);
}
/* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
rangeRepPtr->spanPtr = NULL;
} else if (ListSpanMerited(rangeLen, srcRepPtr->storePtr->numUsed,
srcRepPtr->storePtr->numAllocated)) {
/* Option 2 - because span would be most efficient */
Tcl_Size spanStart = ListRepStart(srcRepPtr) + fromIdx;
if (!preserveSrcRep && srcRepPtr->spanPtr
&& srcRepPtr->spanPtr->refCount <= 1) {
/* If span is not shared reuse it */
/* T:listrep-2.7.3,3.{16,18} */
srcRepPtr->spanPtr->spanStart = spanStart;
srcRepPtr->spanPtr->spanLength = rangeLen;
*rangeRepPtr = *srcRepPtr;
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 |
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
| | | | | | | | | < | | | 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 |
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
ListRepInit(rangeLen, &srcElems[fromIdx], LISTREP_PANIC_ON_FAIL
,rangeRepPtr);
} else {
/*
* Option 4 - modify in place. Note that because of the invariant
* that spanless list stores must start at 0, we have to move
* everything to the front.
* TODO - perhaps if a span already exists, no need to move to front?
* or maybe no need to move all the way to the front?
* TODO - if range is small relative to allocation, allocate new?
*/
/* Asserts follow from call to ListRepFreeUnreferenced earlier */
LIST_ASSERT(!preserveSrcRep);
LIST_ASSERT(!ListRepIsShared(srcRepPtr));
LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* Free leading elements outside range */
if (fromIdx != 0) {
/* T:listrep-1.4,3.15 */
ObjArrayDecrRefs(srcElems, 0, fromIdx);
}
/* Ditto for trailing */
numAfterRangeEnd = numSrcElems - (toIdx + 1);
/* Assert: Because numSrcElems > toIdx earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-3.17 */
ObjArrayDecrRefs(srcElems, toIdx + 1, numAfterRangeEnd);
}
memmove(&srcRepPtr->storePtr->slots[0], &srcRepPtr->storePtr
->slots[srcRepPtr->storePtr->firstUsed + fromIdx]
, rangeLen * sizeof(Tcl_Obj *));
srcRepPtr->storePtr->firstUsed = 0;
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
if (srcRepPtr->spanPtr) {
/* In case the source has a span, update it for consistency */
/* T:listrep-3.{15,17} */
srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed;
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 | /* *---------------------------------------------------------------------- * * TclListObjRange -- * * Makes a slice of a list value. | | | > > | > | | > > > > > > > > > | > | > > > > > > > | | > > | | > | | | | | > | | | 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 |
/*
*----------------------------------------------------------------------
*
* TclListObjRange --
*
* Makes a slice of a list value.
* *listObj must be known to be a valid list.
*
* Results:
* Returns a pointer to the sliced list.
* This may be a new object or the same object if not shared.
* Returns NULL if passed listObj was not a list and could not be
* converted to one.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
int
TclListObjRange(tclObjTypeInterfaceArgsListRange)
{
int status;
Tcl_Size length;
status = TclListObjLength(interp, listPtr, &length);
if (status != TCL_OK) {
return status;
}
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
if (Tcl_LengthIsFinite(length) && toIdx + 1 >= length + 1) {
toIdx = length-1;
}
if (fromIdx + 1 > toIdx + 1) {
Tcl_Obj *obj;
TclNewObj(obj);
*resPtrPtr = obj;
return TCL_OK;
}
return TclObjectDispatch(listPtr, ListObjRange, list,
range, interp, listPtr, fromIdx, toIdx, resPtrPtr);
}
int
ListObjRange(tclObjTypeInterfaceArgsListRange)
{
ListRep listRep;
ListRep resultRep;
int isShared, status;
status = TclListObjGetRep(interp, listPtr, &listRep);
if (status != TCL_OK) {
return status;
}
isShared = Tcl_IsShared(listPtr);
ListRepRange(&listRep, fromIdx, toIdx, isShared, &resultRep);
if (isShared) {
/* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
TclNewObj(listPtr);
} /* T:listrep-1.{4.3,5.1,5.2} */
ListObjReplaceRepAndInvalidate(listPtr, &resultRep);
*resPtrPtr = listPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclListObjGetElement --
*
* Returns a single element from the array of the elements in a list
* object, without doing doing any bounds checking. Caller must ensure
* that ObjPtr of of type 'tclListTypePtr' and that index is valid for the
* list.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjGetElement(
|
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 | * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. * *---------------------------------------------------------------------- */ | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | < < > | | > | < | > < < < | < | 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 |
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjGetElements --
*
* Returns an (objc,objv) array of the elements in a list
* object.
*
* Results:
* The return value is normally TCL_OK; in this case *objcPtr is set to
* the count of list elements and *objvPtr is set to a pointer to an
* array of (*objcPtr) pointers to each list element. If listPtr does not
* refer to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in the
* interpreter's result if interp is not NULL.
*
* The objects referenced by the returned array should be treated as
* readonly and their ref counts are _not_ incremented; the caller must
* do that if it holds on to a reference. Furthermore, the pointer and
* length returned by this function may change as soon as any function is
* called on the list object; be careful about retaining the pointer in a
* local data structure.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ListObjGetElements
int
Tcl_ListObjGetElements(tclObjTypeInterfaceArgsListAll)
{
return TclObjectDispatch(listPtr, ListObjInterfaceGetElements,
list, all, interp, listPtr, objcPtr, objvPtr);
}
int
ListObjInterfaceGetElements(tclObjTypeInterfaceArgsListAll)
{
ListRep listRep;
if (TclListObjGetRep(interp, listPtr, &listRep) != TCL_OK)
return TCL_ERROR;
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 | * converted, if necessary, to list objects. Also, appending the new * elements may cause toObj's array of element pointers to grow. * toObj's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ int | | < > | | > | | < > | > | > > > > > > > > > > | | | | > > > | < | | > > > | > > | | | | 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 |
* converted, if necessary, to list objects. Also, appending the new
* elements may cause toObj's array of element pointers to grow.
* toObj's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendList(tclObjTypeInterfaceArgsListAppendList)
{
return TclObjectDispatch(listPtr, ListObjAppendList,
list, appendlist, interp, listPtr, elemListPtr);
}
int
ListObjAppendList(tclObjTypeInterfaceArgsListAppendList)
{
int status;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
if (TclObjectHasInterface(listPtr, list, replaceList)) {
TclObjectDispatchNoDefault(interp, status, listPtr, list,
replaceList, interp, listPtr, LIST_MAX, 0, elemListPtr);
return status;
} else {
Tcl_Size objc;
Tcl_ListObjLength(interp, elemListPtr, &objc);
if (objc == 1) {
Tcl_Obj *itemObj;
status = Tcl_ListObjIndex(interp, elemListPtr, 0, &itemObj);
if (status != TCL_OK) {
return TCL_ERROR;
}
status = Tcl_ListObjAppendElement(interp, listPtr, itemObj);
return status;
} else {
Tcl_Obj **objv;
/*
* Pull the elements to append from elemListPtr.
*/
if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
return TCL_ERROR;
}
return TclListObjAppendElements(interp, listPtr, objc, objv);
}
}
}
/*
*------------------------------------------------------------------------
*
* TclListObjAppendElements --
*
* Appends multiple elements to a Tcl_Obj list object. If
* the passed Tcl_Obj is not a list object, it will be converted to one
* and an error raised if the conversion fails.
*
* The Tcl_Obj must not be shared though the internal representation
* may be.
*
* Results:
* On success, TCL_OK is returned with the specified elements appended.
* On failure, TCL_ERROR is returned with an error message in the
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 |
* in 'listObj' to grow. Any preexisting string representation of
* 'listPtr' is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append elemObj to. */
Tcl_Obj *elemObj) /* Object to append to toObj's list. */
{
/*
* TODO - compare perf with 8.6 to see if worth optimizing single
* element case
| > > > > > > > > > > > > > > | 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 |
* in 'listObj' to grow. Any preexisting string representation of
* 'listPtr' is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendElement(
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
{
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
return TclObjectDispatch(listPtr, ListObjAppendElement,
list, append, interp, listPtr, objPtr);
}
int
ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *toObj, /* List object to append elemObj to. */
Tcl_Obj *elemObj) /* Object to append to toObj's list. */
{
/*
* TODO - compare perf with 8.6 to see if worth optimizing single
* element case
|
| ︙ | ︙ | |||
1946 1947 1948 1949 1950 1951 1952 | * * Effect: * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ int | | < > | | < > | > > | | < < < < < | > | | | < | < | < < < > | | < < < < | | | | < | < | < < < < < < < < < | 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 |
*
* Effect:
* If 'listPtr' is not already of type 'tclListType', it is converted.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(tclObjTypeInterfaceArgsListIndex)
{
return TclObjectDispatch(listPtr, ListObjIndex,
list, index, interp, listPtr, index, resPtrPtr);
}
int
ListObjIndex(tclObjTypeInterfaceArgsListIndex) {
Tcl_Obj **elemObjs;
Tcl_Size numElems;
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listPtr->bytes == &tclEmptyString) {
*resPtrPtr = NULL;
return TCL_OK;
}
if (TclListObjGetElements(interp, listPtr, &numElems, &elemObjs)
!= TCL_OK) {
return TCL_ERROR;
}
if ((index < 0) || (index >= numElems)) {
*resPtrPtr = NULL;
} else {
*resPtrPtr = elemObjs[index];
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjLength --
*
* Returns the number of elements in a list object. If the object is not
* already a list object, attempts to convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case *lenPtr will be set
* to the integer count of list elements. If listPtr does not refer to a
* list object and the object can not be converted to one, TCL_ERROR is
* returned and an error message will be left in the interpreter's result
* if interp is not NULL.
*
* Side effects:
* The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
#undef Tcl_ListObjLength
int
Tcl_ListObjLength(tclObjTypeInterfaceArgsListLength)
{
return TclObjectDispatch(listPtr, ListObjInterfaceLength,
list, length, interp, listPtr, lenPtr);
}
int
ListObjInterfaceLength(tclObjTypeInterfaceArgsListLength) {
ListRep listRep;
if (TclListObjGetRep(interp, listPtr, &listRep) != TCL_OK) {
return TCL_ERROR;
}
*lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjReplace --
*
* This function replaces zero or more elements of the list referenced by
|
| ︙ | ︙ | |||
2075 2076 2077 2078 2079 2080 2081 | * replaced objects are decremented. listObj is converted, if necessary, * to a list object. listObj's old string representation, if any, is * freed. * *---------------------------------------------------------------------- */ int | | > > > > > | > > > | > > > > | > > > > > > | > > > | > > > > > > | > > > > > > > > > > > > > > > > > < < < < < | 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 |
* replaced objects are decremented. listObj is converted, if necessary,
* to a list object. listObj's old string representation, if any, is
* freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjReplace(tclObjTypeInterfaceArgsListReplace)
{
Tcl_Size length, status;
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (first < 0) {
first = 0;
}
status = Tcl_ListObjLength(interp, listObj, &length);
if (status != TCL_OK) {
return status;
}
/* go through the process even in this case to ensure that the result is a
* cononical list
*if (length == 0 && numToInsert == 0) {
* return TCL_OK;
*}
*/
if (first >= length) {
first = length; /* So we'll insert after last element. */
}
if (numToDelete < 0) {
numToDelete = 0;
} else if (first > INT_MAX - numToDelete /* Handle integer overflow */
|| length < first+numToDelete) {
numToDelete = length - first;
}
if (numToDelete > LIST_MAX - (length - numToDelete)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%" TCL_Z_MODIFIER
"u elements) exceeded", LIST_MAX));
}
return TCL_ERROR;
}
return TclObjectDispatch(listObj, ListObjReplace,
list, replace, interp, listObj, first, numToDelete, numToInsert, insertObjs);
}
int
ListObjReplace(tclObjTypeInterfaceArgsListReplace)
{
ListRep listRep;
Tcl_Size origListLen;
Tcl_Size lenChange;
Tcl_Size leadSegmentLen;
Tcl_Size tailSegmentLen;
Tcl_Size numFreeSlots;
Tcl_Size leadShift;
Tcl_Size tailShift;
Tcl_Obj **listObjs;
int favor;
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
/* Cannot be converted to a list */
return TCL_ERROR;
}
/* Make limits sane */
origListLen = ListRepLength(&listRep);
|
| ︙ | ︙ | |||
2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 |
}
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclLindexList --
*
| > > > > > > > > > > > | | 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 |
}
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
int
ListObjStringIsEmpty(tclObjTypeInterfaceArgsStringIsEmpty) {
int status;
if (!TclHasInternalRep(listPtr, tclListTypePtr)) {
Tcl_Panic("%s called Tcl_Obj whose type is not tclListType", "listObjStringIsEmpty");
}
status = TclCheckEmptyString(interp, listPtr, res);
return status;
}
/*
*----------------------------------------------------------------------
*
* TclLindexList --
*
* Handles the 'lindex' command when objc==3.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an error
* occurred. The returned object already includes one reference count for
* the pointer returned.
*
* Side effects:
|
| ︙ | ︙ | |||
2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 |
Tcl_Obj *listObj, /* List being unpacked. */
Tcl_Obj *argObj) /* Index or index list. */
{
Tcl_Size index; /* Index into the list. */
Tcl_Obj *indexListCopy;
Tcl_Obj **indexObjs;
Tcl_Size numIndexObjs;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
* shimmering; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
| > | | | | | | | | | | > | > > > > > > > > > > | < | 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 |
Tcl_Obj *listObj, /* List being unpacked. */
Tcl_Obj *argObj) /* Index or index list. */
{
Tcl_Size index; /* Index into the list. */
Tcl_Obj *indexListCopy;
Tcl_Obj **indexObjs;
Tcl_Size numIndexObjs;
int status;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
* shimmering; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
if (!TclHasInternalRep(argObj, tclListTypePtr)
&& TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1,
&index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
* Make a private copy of the index list argument to keep the internal
* representation of the indices array unchanged while it is in use. This
* is probably unnecessary. It does not appear that any damaging change to
* the internal representation is possible, and no test has been devised to
* show any error when this private copy is not made, But it's cheap, and
* it offers some future-proofing insurance in case the TclLindexFlat
* implementation changes in some unexpected way, or some new form of trace
* or callback permits things to happen that the current implementation
* does not.
*/
indexListCopy = TclDuplicatePureObj(interp, argObj, tclListTypePtr);
if (!indexListCopy) {
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
status = TclListObjGetElements(
interp, indexListCopy, &numIndexObjs, &indexObjs);
if (status != TCL_OK) {
Tcl_DecrRefCount(indexListCopy);
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
return listObj;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 |
Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
int status;
Tcl_Size i;
| < < < < < < < < < < < < < < < < < < < < < < < < < | 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 |
Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
int status;
Tcl_Size i;
Tcl_IncrRefCount(listObj);
for (i=0 ; i<indexCount && listObj ; i++) {
Tcl_Size index, listLen = 0;
Tcl_Obj **elemPtrs = NULL;
status = Tcl_ListObjLength(interp, listObj, &listLen);
|
| ︙ | ︙ | |||
2705 2706 2707 2708 2709 2710 2711 |
return NULL;
}
}
Tcl_DecrRefCount(listObj);
TclNewObj(listObj);
Tcl_IncrRefCount(listObj);
} else {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | < | | | | > | | 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 |
return NULL;
}
}
Tcl_DecrRefCount(listObj);
TclNewObj(listObj);
Tcl_IncrRefCount(listObj);
} else {
Tcl_Obj* listItem;
if (TclIndexIsFromEnd(index)
&& TclObjectHasInterface(listObj, list, indexEnd)
&& Tcl_LengthIsFinite(listLen)
) {
TclObjectDispatchNoDefault(interp, status, listObj,
list, indexEnd, interp, listObj, index, &listItem);
if (status == TCL_OK) {
Tcl_IncrRefCount(listItem);
Tcl_DecrRefCount(listObj);
listObj = listItem;
} else {
Tcl_DecrRefCount(listObj);
return NULL;
}
} else if (TclObjectHasInterface(listObj, list, index)) {
TclObjectDispatchNoDefault(interp, status, listObj,
list, index, interp, listObj, index, &listItem);
if (status == TCL_OK) {
Tcl_IncrRefCount(listItem);
Tcl_DecrRefCount(listObj);
listObj = listItem;
} else {
Tcl_DecrRefCount(listObj);
return NULL;
}
} else {
/*
* Must set the internal rep again because it may have been
* changed by TclGetIntForIndexM. See test lindex-8.4.
*/
if (!TclHasInternalRep(listObj, tclListTypePtr)) {
status = TclSetListFromAny(interp, listObj);
if (status != TCL_OK) {
/* The list is not a list at all => error. */
Tcl_DecrRefCount(listObj);
return NULL;
}
}
ListObjGetElements(listObj, listLen, elemPtrs);
/* increment this reference count first before decrementing
* just in case they are the same Tcl_Obj
*/
Tcl_IncrRefCount(elemPtrs[index]);
Tcl_DecrRefCount(listObj);
/* Extract the pointer to the appropriate element. */
listObj = elemPtrs[index];
}
}
} else {
Tcl_DecrRefCount(listObj);
listObj = NULL;
}
}
return listObj;
}
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if there was an
* error. The returned object includes one reference count for the
* pointer returned.
*
* Side effects:
|
| ︙ | ︙ | |||
2770 2771 2772 2773 2774 2775 2776 |
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
| | | | | | | < < < < < < < < | | < | > > > | < | > | | | | | | < > > | | | | | | | | | | > | | | | < | < < < < < | | | | < < < | < | < | < < < < < < < < < < < < < > | > | < > | | > | | > > | | < < | | < < < < < < | | > > > > > | 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 |
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listObj, /* Pointer to the list being modified. */
Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
Tcl_Size indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *resPtr; /* Pointer to the list to be returned. */
Tcl_Size index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
/*
* Determine whether the index arg designates a list or a single index.
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
if (!TclHasInternalRep(indexArgObj, tclListTypePtr)
&& TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
/* indexArgPtr designates a single index. */
/* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
/* to do: have TclLsetList return a standard return value instead */
TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj, &resPtr);
return resPtr;
}
indexListCopy = TclDuplicatePureObj(
interp, indexArgObj, tclListTypePtr);
if (!indexListCopy) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj, &resPtr);
return resPtr;
}
if (TCL_OK != TclListObjGetElements(
interp, indexListCopy, &indexCount, &indices)) {
Tcl_DecrRefCount(indexListCopy);
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj, &resPtr);
return resPtr;
}
/*
* Let TclLsetFlat perform the actual lset operation.
*/
TclLsetFlat(interp, listObj, indexCount, indices, valueObj, &resPtr);
Tcl_DecrRefCount(indexListCopy);
return resPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLsetFlat --
*
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns a standard Tcl value and stores a pointer to the resulting list
* value in the given address, or stores NULL if an error occurred.
*
* Side effects:
* If the initial value of the list was shared, and this function must
* modify the value, the result is a new object having a reference count
* of 0.
*
*----------------------------------------------------------------------
*/
int
TclLsetFlat(tclObjTypeInterfaceArgsListSetDeep)
{
int status;
status = TclObjectDispatch(listObj, LsetFlat,
list, setDeep, interp, listObj, indexCount, indexArray, valueObj, resPtrPtr);
return status;
}
int
LsetFlat(tclObjTypeInterfaceArgsListSetDeep)
{
Tcl_Size index, len;
int copied = 0, result;
Tcl_Obj *subListObj, *retValueObj;
Tcl_Obj *pendingInvalidates[10];
Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
Tcl_Size numPendingInvalidates = 0;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
* [lpop] does not use this but protect for NULL valueObj just in case.
*/
if (indexCount == 0) {
*resPtrPtr = valueObj;
return TCL_OK;
}
/*
* If the list is shared, make a copy to modify (copy-on-write). The string
* representation and internal representation of listObj remains unchanged.
*/
subListObj = Tcl_IsShared(listObj)
? TclDuplicatePureObj(interp, listObj, tclListTypePtr) : listObj;
if (!subListObj) {
*resPtrPtr = NULL;
return TCL_ERROR;
}
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
retValueObj = subListObj;
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
}
if (index < 0 || index > elemCount
|| (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range", TclGetString(indexArray[-1])));
| | > | | | < | > > > > > > > | > > > > > > > > > > | 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 |
}
if (index < 0 || index > elemCount
|| (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range", TclGetString(indexArray[-1])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE"
, (char *)NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. If this is not the last index, determine the
* next sublist for the next pass through the loop, and take steps to
* make sure it is unshared in order to modify it.
*/
if (--indexCount) {
parentList = subListObj;
if (index == elemCount) {
TclNewObj(subListObj);
} else {
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
subListObj = TclDuplicatePureObj(
interp, subListObj, tclListTypePtr);
if (!subListObj) {
*resPtrPtr = NULL;
return TCL_ERROR;
}
copied = 1;
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its internalrep with other
* Tcl_Obj's. Dealing with the shared internalrep case can
* cause subListObj to become shared again, so detect that case
* and make and store another copy.
*/
if (index == elemCount) {
Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
Tcl_Obj * newSubListObj;
newSubListObj = TclDuplicatePureObj(
interp, subListObj, tclListTypePtr);
if (copied) {
Tcl_DecrRefCount(subListObj);
}
if (newSubListObj) {
subListObj = newSubListObj;
} else {
*resPtrPtr = NULL;
return TCL_ERROR;
}
TclListObjSetElement(NULL, parentList, index, subListObj);
}
/*
* The TclListObjSetElement() calls do not spoil the string rep
* of parentList, and that's fine for now, since all we've done
* so far is replace a list element with an unshared copy. The
|
| ︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 |
* Error return; message is already in interp. Clean up any excess
* memory.
*/
if (retValueObj != listObj) {
Tcl_DecrRefCount(retValueObj);
}
| > | | 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 |
* Error return; message is already in interp. Clean up any excess
* memory.
*/
if (retValueObj != listObj) {
Tcl_DecrRefCount(retValueObj);
}
*resPtrPtr = NULL;
return result;
}
/*
* Store valueObj in proper sublist and return. The -1 is to avoid a
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
|
| ︙ | ︙ | |||
3103 3104 3105 3106 3107 3108 3109 |
/* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
/* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
TclListObjSetElement(NULL, subListObj, index, valueObj);
TclInvalidateStringRep(subListObj);
}
| | | | 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 |
/* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
/* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
TclListObjSetElement(NULL, subListObj, index, valueObj);
TclInvalidateStringRep(subListObj);
}
*resPtrPtr = retValueObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclListObjSetElement --
*
|
| ︙ | ︙ | |||
3133 3134 3135 3136 3137 3138 3139 | * ref count of the object at the specified index within the list, * replaces with the object designated by valueObj, and increments the * ref count of the replacement object. * *---------------------------------------------------------------------- */ int | | < > | | > | < | | | | 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 |
* ref count of the object at the specified index within the list,
* replaces with the object designated by valueObj, and increments the
* ref count of the replacement object.
*
*----------------------------------------------------------------------
*/
int
TclListObjSetElement(tclObjTypeInterfaceArgsListSet)
{
return TclObjectDispatch(listObj, ListObjSetElement,
list, set, interp, listObj, index, valueObj);
}
int
ListObjSetElement(tclObjTypeInterfaceArgsListSet)
{
ListRep listRep;
Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
Tcl_Size elemCount; /* Number of elements in the list. */
/* Ensure that the listObj parameter designates an unshared list. */
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
|
| ︙ | ︙ | |||
3196 3197 3198 3199 3200 3201 3202 |
*/
Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
elemPtrs[index] = valueObj;
/* Internal rep may be cloned so replace */
ListObjReplaceRepAndInvalidate(listObj, &listRep);
| < | 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 |
*/
Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
elemPtrs[index] = valueObj;
/* Internal rep may be cloned so replace */
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeListInternalRep --
|
| ︙ | ︙ | |||
3264 3265 3266 3267 3268 3269 3270 |
ListObjGetRep(srcObj, &listRep);
ListObjOverwriteRep(copyObj, &listRep);
}
/*
*----------------------------------------------------------------------
*
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
ListObjGetRep(srcObj, &listRep);
ListObjOverwriteRep(copyObj, &listRep);
}
/*
*----------------------------------------------------------------------
*
* TclSetListFromAny --
*
* Attempt to generate a list internal form for the Tcl object "objPtr".
*
* Results:
* The return value is TCL_OK or TCL_ERROR. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a list is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
int
TclSetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Tcl_Obj **elemPtrs;
ListRep listRep;
/*
* Dictionaries are a special case; they have a string representation such
* that *all* valid dictionaries are valid lists. Hence we can convert
* more directly. Only do this when there's no existing string rep; if
* there is, it is the string rep that's authoritative (because it could
* describe duplicate keys).
*/
if (TclObjectHasInterface(objPtr, list, index)) {
int status;
Tcl_Size index, length, storeSize, offset;
Tcl_Obj *itemPtr, **lastElemPtr;
status = Tcl_ListObjLength(interp, objPtr, &length);
if (status != TCL_OK) {
return status;
}
storeSize = length;
if (ListRepInitAttempt(
interp, length > 8 ? storeSize : 8, NULL, &listRep)
!= TCL_OK) {
return TCL_ERROR;
}
elemPtrs = listRep.storePtr->slots;
lastElemPtr = elemPtrs + listRep.storePtr->numAllocated - 1;
index = 0;
Tcl_IncrRefCount(objPtr);
while (index < length || length < 0) {
TclObjectDispatchNoDefault(interp, status, objPtr, list,
index, interp, objPtr, index, &itemPtr);
if (status != TCL_OK) {
status = Tcl_ListObjLength(interp, objPtr, &length);
if (status != TCL_OK) {
TclUndoRefCount(objPtr);
return status;
}
continue;
}
if (elemPtrs == lastElemPtr) {
ListStore *newStorePtr;
storeSize += storeSize / 2;
offset = elemPtrs - listRep.storePtr->slots;
newStorePtr = ListStoreReallocate(listRep.storePtr, storeSize);
if (newStorePtr == NULL) {
TclUndoRefCount(objPtr);
return MemoryAllocationError(interp, LIST_SIZE(storeSize));
}
elemPtrs = newStorePtr->slots + offset;
listRep.storePtr = newStorePtr;
lastElemPtr = elemPtrs + listRep.storePtr->numAllocated - 1;
}
listRep.storePtr->numUsed++;
if (itemPtr == objPtr) {
*elemPtrs = Tcl_DuplicateObj(itemPtr);
TclBounceRefCount(itemPtr);
} else {
*elemPtrs = itemPtr;
}
Tcl_IncrRefCount(*elemPtrs);
elemPtrs++;
index++;
}
TclUndoRefCount(objPtr);
} else if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, tclDictTypePtr)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
Tcl_Size size;
/*
* Create the new list representation. Note that we do not need to do
|
| ︙ | ︙ | |||
3334 3335 3336 3337 3338 3339 3340 |
while (!done) {
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < | | 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 |
while (!done) {
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
Tcl_Size estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
estCount = TclMaxListLength(nextElem, length, &limit);
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
* So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
* IncrRefs so do not use ListObjOverwriteRep
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
| | | 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 |
* So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
* IncrRefs so do not use ListObjOverwriteRep
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
objPtr->typePtr = tclListTypePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3521 3522 3523 3524 3525 3526 3527 |
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)Tcl_Alloc(numElems);
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
| | | | 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 |
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)Tcl_Alloc(numElems);
}
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded > SIZE_MAX - numElems) {
Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX);
}
}
bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
/* Set the string length to what was actually written, the safe choice */
(void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | /* * tclLiteral.c -- * * Implementation of the global and ByteCode-local literal tables used to * manage the Tcl objects created for literal values during compilation * of Tcl scripts. This implementation borrows heavily from the more * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. | > > > > > > > > > > > > > > > > > < < < < < < | 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 | /* * Copyright © 1997-1998 Sun Microsystems, Inc. * Copyright © 2004 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLiteral.c -- * * Implementation of the global and ByteCode-local literal tables used to * manage the Tcl objects created for literal values during compilation * of Tcl scripts. This implementation borrows heavily from the more * general hashtable implementation of Tcl hash tables that appears in * tclHash.c. */ #include "tclInt.h" #include "tclCompile.h" /* * When there are this many entries per bucket, on average, rebuild a |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable( | | < | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
* The literal table is made ready for use.
*
*----------------------------------------------------------------------
*/
void
TclInitLiteralTable(
LiteralTable *tablePtr) /* Pointer to table structure, which is
* supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable",
TCL_SMALL_HASH_TABLE);
#endif
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
| | | | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
Tcl_Size length, /* Number of bytes in the string. */
size_t hash, /* The string's hash. If the value is
* TCL_INDEX_NONE, it will be computed here. */
int *newPtr,
Namespace *nsPtr,
int flags,
LiteralEntry **globalPtrPtr)
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | * Literals should always have UTF-8 representations... but this * is not guaranteed so we need to be careful anyway. * * https://stackoverflow.com/q/54337750/301832 */ Tcl_Size objLength; | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
* Literals should always have UTF-8 representations... but this
* is not guaranteed so we need to be careful anyway.
*
* https://stackoverflow.com/q/54337750/301832
*/
Tcl_Size objLength;
const char *objBytes = Tcl_GetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
&& (memcmp(objBytes, bytes, length) == 0)))) {
/*
* A literal was found: return it
*/
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | * buffer holding the result of backslash substitutions. * *---------------------------------------------------------------------- */ int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ TclRegisterLiteral( | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
* buffer holding the result of backslash substitutions.
*
*----------------------------------------------------------------------
*/
int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
Tcl_Size length, /* Number of bytes in the string. If -1, the
* string consists of all bytes up to the
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
* malloc'd bytes and ownership is passed to
* this function. If LITERAL_CMD_NAME then
* the literal should not be shared across
* namespaces. */
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
*----------------------------------------------------------------------
*/
static LiteralEntry *
LookupLiteralEntry(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | | 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 |
*----------------------------------------------------------------------
*/
static LiteralEntry *
LookupLiteralEntry(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal
* that was previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *entryPtr;
const char *bytes;
size_t globalHash, length;
bytes = Tcl_GetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
return entryPtr;
}
}
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
*----------------------------------------------------------------------
*/
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
*----------------------------------------------------------------------
*/
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
CompileEnv *envPtr, /* Points to CompileEnv whose literal array
* contains the entry being hidden. */
int index) /* The index of the entry in the literal
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
size_t localHash;
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
| | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
*/
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
bytes = Tcl_GetStringFromObj(newObjPtr, &length);
localHash = HashString(bytes, length) & localTablePtr->mask;
nextPtrPtr = &localTablePtr->buckets[localHash];
for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) {
if (entryPtr == lPtr) {
*nextPtrPtr = lPtr->nextPtr;
lPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 | * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj( | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
* literal object.
*
*----------------------------------------------------------------------
*/
int
TclAddLiteralObj(
CompileEnv *envPtr, /* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The object to insert into the array. */
LiteralEntry **litPtrPtr) /* The location where the pointer to the new
* literal entry should be stored. May be
* NULL. */
{
LiteralEntry *lPtr;
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 | * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ static size_t AddLocalLiteralEntry( | | | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
* array of the CompileEnv's literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
static size_t
AddLocalLiteralEntry(
CompileEnv *envPtr, /* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
int localHash) /* Hash value for the literal's string. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
size_t objIndex;
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
| | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
bytes = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 | * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray( | | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
* The local literal table is updated to refer to the new entries.
*
*----------------------------------------------------------------------
*/
static void
ExpandLocalLiteralArray(
CompileEnv *envPtr) /* Points to the CompileEnv whose object array
* must be enlarged. */
{
/*
* The current allocated local literal entries are stored between elements
* 0 and (envPtr->literalArrayNext - 1) [inclusive].
*/
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 |
*----------------------------------------------------------------------
*/
void
TclReleaseLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | | 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 |
*----------------------------------------------------------------------
*/
void
TclReleaseLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
Tcl_Obj *objPtr) /* Points to a literal object that was
* previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr;
LiteralEntry *entryPtr, *prevPtr;
const char *bytes;
size_t index;
Tcl_Size length;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
bytes = Tcl_GetStringFromObj(objPtr, &length);
index = HashString(bytes, length) & globalTablePtr->mask;
/*
* Check to see if the object is in the global literal table and remove
* this reference. The object may not be in the table if it is a hidden
* local literal.
*/
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 | * None. * *---------------------------------------------------------------------- */ static size_t HashString( | | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
* None.
*
*----------------------------------------------------------------------
*/
static size_t
HashString(
const char *string, /* String for which to compute hash value. */
size_t length) /* Number of bytes in the string. */
{
size_t result = 0;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 | * Memory gets reallocated and entries get rehashed into new buckets. * *---------------------------------------------------------------------- */ static void RebuildLiteralTable( | | < | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
* Memory gets reallocated and entries get rehashed into new buckets.
*
*----------------------------------------------------------------------
*/
static void
RebuildLiteralTable(
LiteralTable *tablePtr) /* Local or global table to enlarge. */
{
LiteralEntry **oldBuckets;
LiteralEntry **oldChainPtr, **newChainPtr;
LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
const char *bytes;
size_t oldSize, count, index;
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 |
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
| | | 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr=oldBuckets ; oldSize>0 ; oldSize--,oldChainPtr++) {
for (entryPtr=*oldChainPtr ; entryPtr!=NULL ; entryPtr=*oldChainPtr) {
bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &tablePtr->buckets[index];
entryPtr->nextPtr = *bucketPtr;
*bucketPtr = entryPtr;
}
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 |
size_t i, length, count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != TCL_INDEX_NONE) {
| | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 |
size_t i, length, count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != TCL_INDEX_NONE) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : (int) length), bytes, localPtr->refCount);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
|
| ︙ | ︙ | |||
1235 1236 1237 1238 1239 1240 1241 |
size_t i, length, count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
| | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
size_t i, length, count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : (int)length), bytes, globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyGlobalLiteralTable");
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoad.c -- * * This file provides the generic portion (those that are the same on all * platforms) of Tcl's dynamic loading facilities. */ #include "tclInt.h" /* * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call * to Tcl_StaticLibrary). All such libraries are linked together into a * single list for the process. |
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
if (TclGetString(objv[1])[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
| | > | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
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 == index) {
flags |= TCL_LOAD_GLOBAL;
} else if (LOAD_LAZY == index) {
flags |= TCL_LOAD_LAZY;
} else {
break;
}
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 |
void
Tcl_StaticLibrary(
Tcl_Interp *interp, /* If not NULL, it means that the library has
* already been loaded into the given
* interpreter by calling the appropriate init
* proc. */
| | | 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 |
void
Tcl_StaticLibrary(
Tcl_Interp *interp, /* If not NULL, it means that the library has
* already been loaded into the given
* interpreter by calling the appropriate init
* proc. */
const char *prefix, /* Prefix. */
Tcl_LibraryInitProc *initProc,
/* Function to call to incorporate this
* library into a trusted interpreter. */
Tcl_LibraryInitProc *safeInitProc)
/* Function to call to incorporate this
* library into a safe interpreter (one that
* will execute untrusted scripts). NULL means
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadNone.c -- * * This procedure provides a version of the TclpDlopen for use in * systems that don't support dynamic loading; it just returns an error. */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * TclpDlopen -- * |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * This file contains a generic main program for Tcl shells and other * Tcl-based applications. It can be used as-is for many applications, * just by supplying a different appInitProc function for each specific * application. Or, it can be used as a template for creating new main * programs for Tcl applications. | > > > > > > > > > > > > > > > > > > < < < < < < < | 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 | /* * Copyright © 1988-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * This file contains a generic main program for Tcl shells and other * Tcl-based applications. It can be used as-is for many applications, * just by supplying a different appInitProc function for each specific * application. Or, it can be used as a template for creating new main * programs for Tcl applications. */ /* * On Windows, this file needs to be compiled twice, once with UNICODE and * _UNICODE defined. This way both Tcl_Main and Tcl_MainExW can be * implemented, sharing the same source code. */ |
| ︙ | ︙ | |||
272 273 274 275 276 277 278 | * interpreted. * *---------------------------------------------------------------------- */ TCL_NORETURN void Tcl_MainEx( | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
* interpreted.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
Tcl_MainEx(
Tcl_Size argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
|
| ︙ | ︙ | |||
731 732 733 734 735 736 737 | * Could be almost arbitrary, depending on the command that's typed. * *---------------------------------------------------------------------- */ static void StdinProc( | | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
* Could be almost arbitrary, depending on the command that's typed.
*
*----------------------------------------------------------------------
*/
static void
StdinProc(
void *clientData, /* The state of interactive cmd line */
TCL_UNUSED(int) /*mask*/)
{
int code;
Tcl_Size length;
InteractiveState *isPtr = (InteractiveState *)clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
|
| ︙ | ︙ |
1 | /* | < < < < < < < < > > > > > > > > > > > > > > > > > > > | 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 © 1993-1997 Lucent Technologies. * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2002-2005 Donal K. Fellows. * Copyright © 2006 Neil Madden. * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclNamesp.c -- * * Contains support for namespaces, which provide a separate context of * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain * special-purpose commands and variables for packages. */ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ #include <assert.h> /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | const char *name2, int flags); static char * EstablishErrorInfoTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); | | < < | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | const char *name2, int flags); static char * EstablishErrorInfoTraces(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static Tcl_ObjCmdProc InvokeImportedNRCmd; static Tcl_ObjCmdProc NamespaceChildrenCmd; static Tcl_ObjCmdProc NamespaceCodeCmd; static Tcl_ObjCmdProc NamespaceCurrentCmd; static Tcl_ObjCmdProc NamespaceDeleteCmd; static Tcl_ObjCmdProc NamespaceEvalCmd; static Tcl_ObjCmdProc NRNamespaceEvalCmd; static Tcl_ObjCmdProc NamespaceExistsCmd; |
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
static const Tcl_ObjType nsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny, /* setFromAnyProc */
| < > | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
static const Tcl_ObjType nsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny, /* setFromAnyProc */
0
};
#define NsNameSetInternalRep(objPtr, nnPtr) \
do { \
Tcl_ObjInternalRep ir; \
(nnPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (nnPtr); \
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals + 1 > 1) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
}
|
| ︙ | ︙ | |||
1712 1713 1714 1715 1716 1717 1718 |
/*
* 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) {
| | | 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 |
/*
* 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", (char *)NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
|
| ︙ | ︙ | |||
2305 2306 2307 2308 2309 2310 2311 |
* NULL. */
const char **simpleNamePtr) /* Address where function stores the simple
* name at end of the qualName, or NULL if
* qualName is "::" or the flag
* TCL_FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
| | | 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 |
* NULL. */
const char **simpleNamePtr) /* Address where function stores the simple
* name at end of the qualName, or NULL if
* qualName is "::" or the flag
* TCL_FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
const char *start, *end;
const char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
|
| ︙ | ︙ | |||
2438 2439 2440 2441 2442 2443 2444 |
nsPtr = (Namespace *)
Tcl_CreateNamespace(interp, nsName, NULL, NULL);
TclPopStackFrame(interp);
if (nsPtr == NULL) {
Tcl_Panic("Could not create namespace '%s'", nsName);
}
| < < | < | < < < < < < < < < < < < < < | 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 |
nsPtr = (Namespace *)
Tcl_CreateNamespace(interp, nsName, NULL, NULL);
TclPopStackFrame(interp);
if (nsPtr == NULL) {
Tcl_Panic("Could not create namespace '%s'", nsName);
}
} else { /* Namespace not found and was not
* created. */
nsPtr = NULL;
}
}
/*
* Look up the namespace qualifier in the alternate search path too.
*/
if (altNsPtr != NULL) {
entryPtr = FindChildEntry(altNsPtr, nsName);
if (entryPtr != NULL) {
altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
*/
if ((nsPtr == NULL) && (altNsPtr == NULL)) {
*simpleNamePtr = NULL;
goto done;
}
start = end;
}
|
| ︙ | ︙ | |||
3263 3264 3265 3266 3267 3268 3269 |
* If "arg" is already a scoped value, then return it directly.
* Take care to only check for scoping in precisely the style that
* [::namespace code] generates it. Anything more forgiving can have
* the effect of failing in namespaces that contain their own custom
" "namespace" command. [Bug 3202171].
*/
| | | 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
* If "arg" is already a scoped value, then return it directly.
* Take care to only check for scoping in precisely the style that
* [::namespace code] generates it. Anything more forgiving can have
* the effect of failing in namespaces that contain their own custom
" "namespace" command. [Bug 3202171].
*/
arg = Tcl_GetStringFromObj(objv[1], &length);
if (*arg==':' && length > 20
&& strncmp(arg, "::namespace inscope ", 20) == 0) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3841 3842 3843 3844 3845 3846 3847 |
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc == DeleteImportedCmd) {
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
| | | 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 |
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc == DeleteImportedCmd) {
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
(char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr), -1));
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 |
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
cmd = Tcl_GetCommandFromObj(interp, objv[1]);
if (cmd == NULL) {
goto namespaceOriginError;
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
| > > > > > | | 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 |
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command cmd, origCmd;
Tcl_Obj *resultPtr;
int isEmpty, status;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
cmd = Tcl_GetCommandFromObj(interp, objv[1]);
if (cmd == NULL) {
goto namespaceOriginError;
}
origCmd = TclGetOriginalCommand(cmd);
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
status = TclCheckEmptyString(interp ,resultPtr, &isEmpty);
if (status) {
return TCL_ERROR;
}
if (isEmpty == TCL_EMPTYSTRING_YES) {
Tcl_DecrRefCount(resultPtr);
goto namespaceOriginError;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
namespaceOriginError:
|
| ︙ | ︙ | |||
4765 4766 4767 4768 4769 4770 4771 |
goto badArgs;
}
}
TclNewObj(resultPtr);
switch (lookupType) {
case 0: { /* -command */
| | | | 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 |
goto badArgs;
}
}
TclNewObj(resultPtr);
switch (lookupType) {
case 0: { /* -command */
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc - 1]);
if (cmd != NULL) {
Tcl_GetCommandFullName(interp, cmd, resultPtr);
}
break;
}
case 1: { /* -variable */
Tcl_Var var = Tcl_FindNamespaceVar(interp,
TclGetString(objv[objc - 1]), NULL, /*flags*/ 0);
if (var != NULL) {
Tcl_GetVariableFullName(interp, var, resultPtr);
}
break;
}
}
|
| ︙ | ︙ | |||
4903 4904 4905 4906 4907 4908 4909 |
if (interp == NULL) {
return TCL_ERROR;
}
name = TclGetString(objPtr);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
| | | 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 |
if (interp == NULL) {
return TCL_ERROR;
}
name = TclGetString(objPtr);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
return TCL_ERROR;
}
/*
* If we found a namespace, then create a new ResolvedNsName structure
|
| ︙ | ︙ |
1 | /* | < < < < < < < < > > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * Copyright © 2003 Kevin B. Kenny. All rights reserved. * Copyright © 2021 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclNotify.c -- * * This file implements the generic portion of the Tcl notifier. The * notifier is lowest-level part of the event system. It manages an event * queue that holds Tcl_Event structures. The platform specific portion * of the notifier is defined in the tcl*Notify.c files in each platform * directory. */ #include "tclInt.h" /* * Notifier hooks that are checked in the public wrappers for the default * notifier functions (for overriding via Tcl_SetNotifier). */ |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
* elapsed time for the next block. */
int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called
* during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in list of
* event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
| | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
* elapsed time for the next block. */
int inTraversal; /* 1 if Tcl_SetMaxBlockTime is being called
* during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in list of
* event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
void *clientData; /* Opaque handle for platform specific
* notifier. */
int initialized; /* 1 if notifier has been initialized. */
struct ThreadSpecificData *nextPtr;
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
} ThreadSpecificData;
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
Tcl_CreateEventSource(
Tcl_EventSetupProc *setupProc,
/* Function to invoke to figure out what to
* wait for. */
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
| | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
Tcl_CreateEventSource(
Tcl_EventSetupProc *setupProc,
/* Function to invoke to figure out what to
* wait for. */
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
void *clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
Tcl_DeleteEventSource(
Tcl_EventSetupProc *setupProc,
/* Function to invoke to figure out what to
* wait for. */
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
| | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
Tcl_DeleteEventSource(
Tcl_EventSetupProc *setupProc,
/* Function to invoke to figure out what to
* wait for. */
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
void *clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr, *prevPtr;
for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL;
sourcePtr != NULL;
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteEvents(
Tcl_EventDeleteProc *proc, /* The function to call. */
| | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteEvents(
Tcl_EventDeleteProc *proc, /* The function to call. */
void *clientData) /* The type-specific data. */
{
Tcl_Event *evPtr; /* Pointer to the event being examined */
Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if
* evPtr designates the first event in the
* queue for the thread. */
Tcl_Event *hold;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
1249 1250 1251 1252 1253 1254 1255 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_AlertNotifier( | | | 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
* See the platform-specific implementations.
*
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
void *clientData) /* Pointer to thread data. */
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
} else {
TclpAlertNotifier(clientData);
}
}
|
| ︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 | * See the platform-specific implementations. * *---------------------------------------------------------------------- */ void Tcl_SetTimer( | | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
* See the platform-specific implementations.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
if (tclNotifierHooks.setTimerProc) {
tclNotifierHooks.setTimerProc(timePtr);
} else {
TclpSetTimer(timePtr);
}
}
|
| ︙ | ︙ | |||
1337 1338 1339 1340 1341 1342 1343 | * Queues file events that are detected by the notifier. * *---------------------------------------------------------------------- */ int Tcl_WaitForEvent( | | | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 |
* Queues file events that are detected by the notifier.
*
*----------------------------------------------------------------------
*/
int
Tcl_WaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
return TclpWaitForEvent(timePtr);
}
}
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
if (tclNotifierHooks.createFileHandlerProc) {
tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData);
} else {
TclpCreateFileHandler(fd, mask, proc, clientData);
}
}
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2005-2019 Donal K. Fellows * Copyright © 2017 Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" /* |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | * Methods in the oo::object and oo::class classes. First, we define a helper * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! * * Note that the core methods don't need clone or free proc callbacks. */ | | | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
* Methods in the oo::object and oo::class classes. First, we define a helper
* macro that makes building the method type declaration structure a lot
* easier. No point in making life harder than it has to be!
*
* Note that the core methods don't need clone or free proc callbacks.
*/
#define DCM(name, visibility, proc) \
{name, visibility, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: "#name, proc, NULL, NULL}}
static const DeclaredClassMethod objMethods[] = {
DCM("destroy", 1, TclOO_Object_Destroy),
DCM("eval", 0, TclOO_Object_Eval),
DCM("unknown", 0, TclOO_Object_Unknown),
DCM("variable", 0, TclOO_Object_LinkVar),
DCM("varname", 0, TclOO_Object_VarName),
|
| ︙ | ︙ | |||
135 136 137 138 139 140 141 | /* * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ static const char initScript[] = | < < < | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
/*
* Scripted parts of TclOO. First, the main script (cannot be outside this
* file).
*/
static const char initScript[] =
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | */ #define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) | | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
*/
#define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING)
#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
#define RemoveItem(type, lst, idx) \
do { \
Remove ## type ((lst).list, (lst).num, idx); \
(lst).num--; \
} while (0)
/*
* ----------------------------------------------------------------------
*
* RemoveClass, RemoveObject --
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
* to be fully provided.
*/
if (Tcl_EvalEx(interp, initScript, TCL_INDEX_NONE, 0) != TCL_OK) {
return TCL_ERROR;
}
| < < < < | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
* to be fully provided.
*/
if (Tcl_EvalEx(interp, initScript, TCL_INDEX_NONE, 0) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2832 2833 2834 2835 2836 2837 2838 |
}
/*
* Invoke the call chain, locking the object structure against deletion
* for the duration.
*/
| | | 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
}
/*
* Invoke the call chain, locking the object structure against deletion
* for the duration.
*/
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL, NULL, NULL);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeObjectCall(
void *data[],
TCL_UNUSED(Tcl_Interp *),
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # tclOO.decls -- # # This file contains the declarations for all supported public functions # that are exported by the TclOO package that is embedded within the Tcl # library via the stubs table. This file is used to generate the # tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. # | > > > > > > > > > > > > < < < < | 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 © 2008-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. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # tclOO.decls -- # # This file contains the declarations for all supported public functions # that are exported by the TclOO package that is embedded within the Tcl # library via the stubs table. This file is used to generate the # tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. # library tclOO ###################################################################### # Public API, exposed for general users of TclOO. # |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * 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). */ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED /* * 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: |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); | < < < < | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv); typedef void (Tcl_MethodDeleteProc)(void *clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, void **newClientData); typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
* data, or NULL if the type-specific data
* does not need deleting. */
Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
* data, or NULL if the type-specific data can
* be copied directly. */
} Tcl_MethodType;
| < < < < | 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 |
* data, or NULL if the type-specific data
* does not need deleting. */
Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
* data, or NULL if the type-specific data can
* be copied directly. */
} Tcl_MethodType;
typedef struct Tcl_MethodType2 {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_2 in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
Tcl_MethodCallProc2 *callProc;
/* How to invoke this method. */
Tcl_MethodDeleteProc *deleteProc;
/* How to delete this method's type-specific
* data, or NULL if the type-specific data
* does not need deleting. */
Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
* data, or NULL if the type-specific data can
* be copied directly. */
} Tcl_MethodType2;
/*
* The correct value for the version field of the Tcl_MethodType structure.
* This allows new versions of the structure to be introduced without breaking
* binary compatibility.
*/
enum TclOOMethodVersion {
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2005-2013 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclTomMath.h" |
| ︙ | ︙ | |||
931 932 933 934 935 936 937 |
context = (Tcl_ObjectContext) framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
* that this is like [uplevel 1] and not [eval].
*/
| | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
context = (Tcl_ObjectContext) framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
* that this is like [uplevel 1] and not [eval].
*/
TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL, NULL, NULL);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
int
TclOONextToObjCmd(
TCL_UNUSED(void *),
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. It also contains everything else that does * inheritance hierarchy traversal. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2005-2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOOCall.c -- * * This file contains the method call chain management code for the * object-system core. It also contains everything else that does * inheritance hierarchy traversal. */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
static const Tcl_ObjType methodNameType = {
"TclOO method name",
FreeMethodNameRep,
DupMethodNameRep,
NULL,
NULL,
| < > | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
static const Tcl_ObjType methodNameType = {
"TclOO method name",
FreeMethodNameRep,
DupMethodNameRep,
NULL,
NULL,
0
};
/*
* ----------------------------------------------------------------------
*
* TclOODeleteContext --
*
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
}
/*
* Save whether we were in a filter and set up whether we are now.
*/
if (contextPtr->oPtr->flags & FILTER_HANDLING) {
| | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
}
/*
* Save whether we were in a filter and set up whether we are now.
*/
if (contextPtr->oPtr->flags & FILTER_HANDLING) {
TclNRAddCallback(interp, SetFilterFlags, contextPtr, NULL, NULL, NULL);
} else {
TclNRAddCallback(interp, ResetFilterFlags, contextPtr, NULL, NULL, NULL);
}
if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
contextPtr->oPtr->flags |= FILTER_HANDLING;
} else {
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOODECLS #define _TCLOODECLS #ifndef TCLAPI # ifdef BUILD_tcl # define TCLAPI extern DLLEXPORT | > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOODECLS #define _TCLOODECLS #ifndef TCLAPI # ifdef BUILD_tcl # define TCLAPI extern DLLEXPORT |
| ︙ | ︙ | |||
266 267 268 269 270 271 272 | #define Tcl_NewMethod2 \ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ | < < < < < < < < < < | 276 277 278 279 280 281 282 283 | #define Tcl_NewMethod2 \ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLOODECLS */ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2006-2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" /* |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 |
typedef struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
const Tcl_MethodType resolverType;
} DeclaredSlot;
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
typedef struct DeclaredSlot {
const char *name;
const Tcl_MethodType getterType;
const Tcl_MethodType setterType;
const Tcl_MethodType resolverType;
} DeclaredSlot;
#define SLOT(name, getter, setter, resolver) \
{"::oo::" name, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
getter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
setter, NULL, NULL}, \
{TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
resolver, NULL, NULL}}
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 |
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (char *)NULL);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
| | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (char *)NULL);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
const char *nameStr = (const char *)
Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
Tcl_Size length;
| | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
Tcl_Size length;
const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
/*
* If someone is playing games, we stop playing right now.
*/
|
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 |
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
Tcl_Size length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
| | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
Tcl_Size length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
const char *objName = Tcl_GetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in definition script for %s \"%.*s%s\" line %d)",
typeOfSubject, (overflow ? limit : (int) length), objName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 |
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
| < | 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
if (clsPtr == NULL) {
return TCL_ERROR;
} else if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
(void) TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
|
| ︙ | ︙ | |||
2674 2675 2676 2677 2678 2679 2680 |
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));
| | | 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 |
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", (char *)NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(clsPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL);
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2006-2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOODefineCmds.c -- * * This file contains the implementation of the ::oo-related [info] * subcommands. */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" static Tcl_ObjCmdProc InfoObjectCallCmd; |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOOInt.h -- * * This file contains the structure definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). */ #ifndef TCL_OO_INTERNAL_H #define TCL_OO_INTERNAL_H 1 #include "tclInt.h" #include "tclOO.h" /* |
| ︙ | ︙ | |||
649 650 651 652 653 654 655 | /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. * REQUIRES DECLARATION: Tcl_Size i; */ | | | | | | | | | > | | | > | | | | | > | | | | 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 |
/*
* A convenience macro for iterating through the lists used in the internal
* memory management of objects.
* REQUIRES DECLARATION: Tcl_Size i;
*/
#define FOREACH(var, ary) \
for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
continue; \
} else if ((var) = (ary).list[i], 1)
/*
* A variation where the array is an array of structs. There's no issue with
* possible NULLs; every element of the array will be iterated over and the
* variable set to a pointer to each of those elements in turn.
* REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details.
*/
#define FOREACH_STRUCT(var, ary) \
if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
* does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
* only iterates over values.
* REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key, val, tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr), \
*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; \
hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val, tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; \
hPtr=Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
* but all arguments are used multiple times and so must have no side effects.
*/
#undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */
#define DUPLICATE(target, source, type) \
do { \
size_t len = sizeof(type) * ((target).num=(source).num); \
if (len != 0) { \
memcpy(((target).list=(type*) \
Tcl_Alloc(len)), (source).list, len); \
} else { \
(target).list = NULL; \
} \
} while(0)
#endif /* TCL_OO_INTERNAL_H */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 2 3 4 5 6 7 8 9 10 | /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus | > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * This file is (mostly) automatically generated from tclOO.decls. */ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2005-2011 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOOMethod.c -- * * This file contains code to create and manage methods. */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" |
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 | * * ---------------------------------------------------------------------- */ // TODO: Check whether Tcl_AppendLimitedToObj() can work here. #define LIMIT 60 | | | 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 |
*
* ----------------------------------------------------------------------
*/
// TODO: Check whether Tcl_AppendLimitedToObj() can work here.
#define LIMIT 60
#define ELLIPSIFY(str, len) \
((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "")
static void
MethodErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
// We pull the method name out of context instead of from argument
|
| ︙ | ︙ |
| ︙ | ︙ | |||
192 193 194 195 196 197 198 | * * We cache the list here so it doesn't vanish from under our * feet if a property implementation does something crazy like * changing the set of properties. The type of copy this does * means that the copy holds the references to the names in the * table. */ | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
*
* We cache the list here so it doesn't vanish from under our
* feet if a property implementation does something crazy like
* changing the set of properties. The type of copy this does
* means that the copy holds the references to the names in the
* table.
*/
tablePtr->listPtr = TclDuplicatePureObj(interp ,listPtr ,tclListTypePtr);
Tcl_IncrRefCount(tablePtr->listPtr);
*cachePtr = tablePtr;
} else {
tablePtr->listPtr = NULL;
}
}
int result = Tcl_GetIndexFromObjStruct(interp, namePtr, tablePtr->names,
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 2012-2018 Donal K. Fellows * Copyright (c) 2013 Andreas Kupries * Copyright (c) 2017 Gerald Lester * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOOScript.h -- * * This file contains support scripts for TclOO. They are defined here so * that the code can be definitely run even in safe interpreters; TclOO's * core setup is safe. */ #ifndef TCL_OO_SCRIPT_H #define TCL_OO_SCRIPT_H /* * The scripted part of the definitions of TclOO. * * Compiled from tools/tclOOScript.tcl by tools/makeHeader.tcl, which |
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * This file is (mostly) automatically generated from tclOO.decls. * It is compiled and linked in with the tclOO package proper. */ #ifdef HAVE_CONFIG_H #include "config.h" | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * This file is (mostly) automatically generated from tclOO.decls. * It is compiled and linked in with the tclOO package proper. */ #ifdef HAVE_CONFIG_H #include "config.h" |
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ #include "tclOOInt.h" MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ #include "tclOOInt.h" MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1995-1997 Sun Microsystems, Inc.
* Copyright © 1999 Scriptics Corporation.
* Copyright © 2001 ActiveState Corporation.
* Copyright © 2005 Kevin B. Kenny. All rights reserved.
* Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
* Copyright © 2021 Nathan Coulter. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclObj.c --
*
* This file contains Tcl object-related functions that are used by many
* Tcl commands.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
/*
* Table of all object types.
*/
static Tcl_HashTable typeTable;
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(tableMutex)
TclObjectTypeType TclObjectTypeType0 = {
(int *)1
};
/*
* Head of the list of free Tcl_Obj structs we maintain.
*/
Tcl_Obj *tclFreeObjList = NULL;
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | * that a Tcl_Obj was not allocated by some * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | * that a Tcl_Obj was not allocated by some * other thread. */ #endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; static void TclThreadFinalizeContLines(void *clientData); static ThreadSpecificData *TclGetContLineTable(void); /* * Nested Tcl_Obj deletion management support * * All context references used in the object freeing code are pointers to this * structure; every thread will have its own structure instance. The purpose |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 | * These are separated out so that some semantic content is attached * to them. */ #define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) | | | | | | | | | 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 |
* These are separated out so that some semantic content is attached
* to them.
*/
#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++)
#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--)
#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0)
#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL)
#define PushObjToDelete(contextPtr, objPtr) \
/* The string rep is already invalidated so we can use the bytes value \
* for our pointer chain: push onto the head of the stack. */ \
(objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \
(contextPtr)->deletionStack = (objPtr)
#define PopObjToDelete(contextPtr, objPtrVar) \
(objPtrVar) = (contextPtr)->deletionStack; \
(contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes
/*
* Macro to set up the local reference to the deletion context.
*/
#if !TCL_THREADS
static PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#elif defined(HAVE_FAST_TSD)
static __thread PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = (PendingObjData *) \
Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData))
#endif
/*
* Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
*/
#define PACK_BIGNUM(bignum, objPtr) \
|
| ︙ | ︙ | |||
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 | static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int copy, mp_int *bignumValue); /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the CommandName object type. */ static void DupCmdNameInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeCmdNameInternalRep(Tcl_Obj *objPtr); static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* * The structures below defines the Tcl object types defined in this file by * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > > | > > > > | | > > > > | > > > | > | > > > | 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 |
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void UpdateStringOfBignum(Tcl_Obj *objPtr);
static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int copy, mp_int *bignumValue);
static int SetDuplicatePureObj(Tcl_Interp *interp,
Tcl_Obj *dupPtr, Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr);
/*
* Prototypes for the array hash key methods.
*/
static Tcl_HashEntry * AllocObjEntry(Tcl_HashTable *tablePtr, void *keyPtr);
/*
* Prototypes for the CommandName object type.
*/
static void DupCmdNameInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static void FreeCmdNameInternalRep(Tcl_Obj *objPtr);
static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int ScalarObjIndex(tclObjTypeInterfaceArgsListIndex);
static int ScalarObjInterfaceListLength(tclObjTypeInterfaceArgsListLength);
static int ScalarObjRange(tclObjTypeInterfaceArgsListRange);
ObjInterface tclScalarInterface = {
1,
{},
{
NULL,
NULL, /* append */
NULL, /* appendList */
NULL, /* contains */
ScalarObjIndex, /* index */
NULL, /* indexEnd */
NULL, /* isSorted */
ScalarObjInterfaceListLength, /* length */
ScalarObjRange, /* range */
NULL, /* rangeEnd */
NULL, /* replace */
NULL, /* replaceList */
NULL, /* reverse */
NULL, /* set */
NULL, /* setList */
},
};
/*
* The structures below defines the Tcl object types defined in this file by
* means of functions that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
const ObjectType tclBooleanObjType= {
"boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny, /* setFromAnyProc */
2,
(Tcl_ObjInterface *)&tclScalarInterface
};
MODULE_SCOPE const Tcl_ObjType *tclBooleanTypePtr
= (Tcl_ObjType *)&tclBooleanObjType;
const ObjectType tclDoubleObjType= {
"double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny, /* setFromAnyProc */
2,
(Tcl_ObjInterface *)&tclScalarInterface
};
MODULE_SCOPE const Tcl_ObjType *tclDoubleTypePtr = (Tcl_ObjType *)&tclDoubleObjType;
const ObjectType tclIntObjType = {
"int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny, /* setFromAnyProc */
2,
(Tcl_ObjInterface *)&tclScalarInterface
};
MODULE_SCOPE const Tcl_ObjType *tclIntTypePtr = (Tcl_ObjType *)&tclIntObjType;
const ObjectType tclBignumObjType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL, /* setFromAnyProc */
2,
(Tcl_ObjInterface *)&tclScalarInterface
};
MODULE_SCOPE const Tcl_ObjType *tclBignumTypePtr
= (Tcl_ObjType *)&tclBignumObjType;
/*
* The structure below defines the Tcl obj hash key type.
*/
const Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 |
Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetCmdNameFromAny, /* setFromAnyProc */
| < > | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetCmdNameFromAny, /* setFromAnyProc */
0
};
/*
* Structure containing a cached pointer to a command that is the result of
* resolving the command's name in some namespace. It is the internal
* representation for a cmdName object. It contains the pointer along with
* some information that is used to check the pointer's validity.
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
| | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(tclDictTypePtr);
Tcl_RegisterObjType(tclDoubleTypePtr);
Tcl_RegisterObjType(tclListTypePtr);
Tcl_RegisterObjType(&tclProcBodyType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclStringType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines, NULL);
}
return tsdPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
*/
Tcl_Free(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size));
| | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
*/
Tcl_Free(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy(&clLocPtr->loc, loc, num*sizeof(Tcl_Size));
clLocPtr->loc[num] = CLL_END; /* Sentinel */
Tcl_SetHashValue(hPtr, clLocPtr);
return clLocPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
| | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
(void)Tcl_GetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
wordCLLast++;
|
| ︙ | ︙ | |||
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 |
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
Tcl_Free(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
* This function is called to register a new Tcl object type in the table
* of all object types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the Tcl type table. If there was already a
* type with the same name as in typePtr, it is replaced with the new
* type.
*
*--------------------------------------------------------------
*/
void
Tcl_RegisterObjType(
const Tcl_ObjType *typePtr) /* Information about object type; storage must
* be statically allocated (must live
* forever). */
{
int isNew;
Tcl_MutexLock(&tableMutex);
Tcl_SetHashValue(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
Tcl_Free(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
Tcl_Free(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
ObjInterface *
TclObjInterface(Tcl_Obj *objPtr) {
ObjectType *otPtr = (ObjectType *)objPtr->typePtr;
if (!otPtr) {
return NULL;
}
if (otPtr->version < 2) {
return NULL;
}
ObjInterface *ifPtr = (ObjInterface *)otPtr->ifPtr;
return ifPtr;
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
* This function is called to register a new Tcl object type in the table
* of all object types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the Tcl type table. If there was already a
* type with the same name as in typePtr, it is replaced with the new
* type.
*
*--------------------------------------------------------------
*/
int TclObjTypeVersion (
const Tcl_ObjType *typePtr)
{
ObjectType *otPtr = (ObjectType *)typePtr;
if ((void *)otPtr->name == (void *)&TclObjectTypeType0) {
return otPtr->version;
}
return 1;
}
const char *TclObjTypeName(
const Tcl_ObjType *typePtr)
{
ObjectType *otPtr = (ObjectType *)typePtr;
return otPtr->name;
}
void
Tcl_RegisterObjType(
const Tcl_ObjType *typePtr) /* Information about object type; storage must
* be statically allocated (must live
* forever). */
{
int isNew;
Tcl_MutexLock(&tableMutex);
const char *name = TclObjTypeName(typePtr);
Tcl_SetHashValue(
Tcl_CreateHashEntry(&typeTable, name, &isNew), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendAllObjTypes --
|
| ︙ | ︙ | |||
936 937 938 939 940 941 942 |
const Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
| | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
const Tcl_ObjType *typePtr) /* The target type. */
{
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
* Use the target type's setFromAnyProc to set "objPtr"s internal form
* as appropriate for the target type. This frees the old internal
* representation.
*/
if (typePtr->setFromAnyProc == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclDbInitNewObj(
Tcl_Obj *objPtr,
| | | | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclDbInitNewObj(
Tcl_Obj *objPtr,
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
objPtr->refCount = 0;
objPtr->typePtr = NULL;
TclInitEmptyStringRep(objPtr);
#if TCL_THREADS
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( | | | | 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewObj(
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
*/
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj( | | | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
*/
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 |
}
}
}
#else /* TCL_MEM_DEBUG */
void
TclFreeObj(
| | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 |
}
}
}
#else /* TCL_MEM_DEBUG */
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 | /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument * object. * * Results: * The return value is a pointer to a newly created Tcl_Obj. This object * has reference count 0 and the same type, if any, as the source object * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; * otherwise, the duplicate's string rep is set NULL to mark it | > > > > > > > > | 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 | /* *---------------------------------------------------------------------- * * Tcl_DuplicateObj -- * * Create and return a new object that is a duplicate of the argument * object. * * TclDuplicatePureObj -- * Like Tcl_DuplicateObj, except that it converts the duplicate to the * specifid typ, does not duplicate the 'bytes' * field unless it is necessary, i.e. the duplicated Tcl_Obj provides no * updateStringProc. This can avoid an expensive memory allocation since * the data in the 'bytes' field of each Tcl_Obj must reside in allocated * memory. * * Results: * The return value is a pointer to a newly created Tcl_Obj. This object * has reference count 0 and the same type, if any, as the source object * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; * otherwise, the duplicate's string rep is set NULL to mark it |
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 | * objects it points to will not actually be copied but will be shared * with the duplicate list. That is, the ref counts of the element * objects will be incremented. * *---------------------------------------------------------------------- */ | | | 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
* objects it points to will not actually be copied but will be shared
* with the duplicate list. That is, the ref counts of the element
* objects will be incremented.
*
*----------------------------------------------------------------------
*/
#define SetDuplicateObj(dupPtr, objPtr) \
{ \
const Tcl_ObjType *typePtr = (objPtr)->typePtr; \
const char *bytes = (objPtr)->bytes; \
if (bytes) { \
TclInitStringRep((dupPtr), bytes, (objPtr)->length); \
} else { \
(dupPtr)->bytes = NULL; \
|
| ︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 |
{
Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
return dupPtr;
}
void
TclSetDuplicateObj(
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr)
{
if (Tcl_IsShared(dupPtr)) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
{
Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
SetDuplicateObj(dupPtr, objPtr);
return dupPtr;
}
/*
*----------------------------------------------------------------------
*
* TclDuplicatePureObj --
*
* Duplicates a Tcl_Obj and converts the internal representation of the
* duplicate to the given type, changing neither the 'bytes' field
* nor the internal representation of the original object, and without
* duplicating the bytes field unless necessary, i.e. unless the
* duplicate provides no updateStringProc after conversion. This can
* avoid an expensive memory allocation since the data in the 'bytes'
* field of each Tcl_Obj must reside in allocated memory.
*
* Results:
* A pointer to a newly-created Tcl_Obj or NULL if there was an error.
* This object has reference count 0. Also:
*
*----------------------------------------------------------------------
*/
int SetDuplicatePureObj(
Tcl_Interp *interp,
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
{
char *bytes = objPtr->bytes;
int status = TCL_OK;
const Tcl_ObjType *useTypePtr =
objPtr->typePtr ? objPtr->typePtr : typePtr;
TclInvalidateStringRep(dupPtr);
assert(dupPtr->typePtr == NULL);
if (objPtr->typePtr && objPtr->typePtr->dupIntRepProc) {
objPtr->typePtr->dupIntRepProc(objPtr, dupPtr);
} else {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = objPtr->typePtr;
}
if (typePtr != NULL && dupPtr->typePtr != useTypePtr) {
if (bytes) {
dupPtr->bytes = bytes;
dupPtr->length = objPtr->length;
}
/* borrow bytes from original object */
status = Tcl_ConvertToType(interp, dupPtr, useTypePtr);
if (bytes) {
dupPtr->bytes = NULL;
dupPtr->length = 0;
}
if (status != TCL_OK) {
return status;
}
}
/* tclStringType is treated as a special case because a Tcl_Obj having this
* type can not always update the string representation. This happens, for
* example, when Tcl_GetCharLength() converts the internal representation
* to tclStringType in order to store the number of characters, but does
* not store enough information to generate the string representation.
*
* Perhaps in the future this can be remedied and this special treatment
* removed.
*/
if (bytes && (dupPtr->typePtr == NULL
|| dupPtr->typePtr->updateStringProc == NULL
|| useTypePtr == &tclStringType
)
) {
if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to initialize string", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
status = TCL_ERROR;
}
}
return status;
}
Tcl_Obj *
TclDuplicatePureObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr
) /* The object to duplicate. */
{
int status;
Tcl_Obj *dupPtr;
TclNewObj(dupPtr);
status = SetDuplicatePureObj(interp, dupPtr, objPtr, typePtr);
if (status == TCL_OK) {
return dupPtr;
} else {
Tcl_DecrRefCount(dupPtr);
return NULL;
}
}
void
TclSetDuplicateObj(
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr)
{
if (Tcl_IsShared(dupPtr)) {
|
| ︙ | ︙ | |||
1600 1601 1602 1603 1604 1605 1606 | * *---------------------------------------------------------------------- */ #undef Tcl_GetString char * Tcl_GetString( | | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 |
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetString
char *
Tcl_GetString(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
if (objPtr->bytes == NULL) {
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant
* of a properly maintained Tcl_Obj is that at least one of
* objPtr->bytes and objPtr->typePtr must not be NULL. If broken
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 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 |
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringFromObj
*
* Returns the string representation's byte array pointer and length for
* an object.
*
* Results:
* Returns a pointer to the string representation of objPtr. If lengthPtr
* isn't NULL, the length of the string representation is stored at
* *lengthPtr. The byte array referenced by the returned pointer must not
* be modified by the caller. Furthermore, the caller must copy the bytes
* if they need to retain them since the object's string rep can change
* as a result of other operations.
*
* Side effects:
* May call the object's updateStringProc to update the string
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
Tcl_Size *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
if (objPtr->bytes == NULL) {
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant
* of a properly maintained Tcl_Obj is that at least one of
* objPtr->bytes and objPtr->typePtr must not be NULL. If broken
* extensions fail to maintain that invariant, we can crash here.
*/
if (objPtr->typePtr->updateStringProc == NULL) {
/*
* Those Tcl_ObjTypes which choose not to define an
|
| ︙ | ︙ | |||
1786 1787 1788 1789 1790 1791 1792 | * As described above. * *---------------------------------------------------------------------- */ char * Tcl_InitStringRep( | | | 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 |
* As described above.
*
*----------------------------------------------------------------------
*/
char *
Tcl_InitStringRep(
Tcl_Obj *objPtr, /* Object whose string rep is to be set */
const char *bytes,
size_t numBytes)
{
assert(objPtr->bytes == NULL || bytes == NULL);
if (objPtr->bytes == NULL) {
/* Start with no string rep */
|
| ︙ | ︙ | |||
1857 1858 1859 1860 1861 1862 1863 | * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( | | | | 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 |
* the string representation NULL to mark it invalid.
*
*----------------------------------------------------------------------
*/
void
Tcl_InvalidateStringRep(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be freed. */
{
TclInvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_HasStringRep --
*
* This function reports whether object has a string representation.
*
* Results:
* Boolean.
*----------------------------------------------------------------------
*/
int
Tcl_HasStringRep(
Tcl_Obj *objPtr) /* Object to test */
{
return TclHasStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
*----------------------------------------------------------------------
*/
void
Tcl_StoreInternalRep(
Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
const Tcl_ObjType *typePtr, /* New type for the object */
| | > | 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
*----------------------------------------------------------------------
*/
void
Tcl_StoreInternalRep(
Tcl_Obj *objPtr, /* Object whose internal rep should be set. */
const Tcl_ObjType *typePtr, /* New type for the object */
const Tcl_ObjInternalRep *irPtr)
/* New internalrep for the object */
{
/* Clear out any existing internalrep ( "shimmer" ) */
TclFreeInternalRep(objPtr);
/* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */
if (irPtr) {
/* Copy the new internalrep into place */
|
| ︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 | * Sets typePtr field to NULL. * *---------------------------------------------------------------------- */ void Tcl_FreeInternalRep( | | | 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 |
* Sets typePtr field to NULL.
*
*----------------------------------------------------------------------
*/
void
Tcl_FreeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */
{
TclFreeInternalRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 | * * Side effects: * The internalrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ | < | | | > | | > | > > | > > | | | > | > > < | | | | > | 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 |
*
* Side effects:
* The internalrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBoolFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int flags,
char *charPtr) /* Place to store resulting boolean. */
{
int result;
if ((flags & TCL_NULL_OK)
&& (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) {
result = -1;
goto boolEnd;
} else if (objPtr == NULL) {
if (interp) {
TclNewObj(objPtr);
TclParseNumber(interp, objPtr,
(flags & TCL_NULL_OK)
? "boolean value or \"\""
: "boolean value",
NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
if (TclHasInternalRep(objPtr, tclIntTypePtr)
|| TclHasInternalRep(objPtr, tclBooleanTypePtr)) {
result = (objPtr->internalRep.wideValue != 0);
goto boolEnd;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the internalrep to 0.0. This isn't
* reliable because a "double" Tcl_ObjType can hold the NaN value.
* Use the API Tcl_GetDoubleFromObj, which does the checking and
* sets the proper error message for us.
*/
double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
result = (d != 0.0);
goto boolEnd;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
result = 1;
boolEnd:
if (charPtr != NULL) {
flags &= (TCL_NULL_OK-2);
if (flags) {
if (flags == (int)sizeof(int)) {
*(int *)charPtr = result;
return TCL_OK;
} else if (flags == (int)sizeof(short)) {
*(short *)charPtr = result;
return TCL_OK;
} else {
Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj");
}
}
*charPtr = result;
}
return TCL_OK;
}
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr,
(flags & TCL_NULL_OK)
? "boolean value or \"\""
: "boolean value",
NULL, -1, NULL, 0)));
return TCL_ERROR;
}
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int *intPtr) /* Place to store resulting boolean. */
{
return Tcl_GetBoolFromObj(interp, objPtr,
(TCL_NULL_OK - 2) & (int) sizeof(int), (char *)(void *)intPtr);
}
/*
*----------------------------------------------------------------------
*
* TclSetBooleanFromAny --
*
|
| ︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 |
*
*----------------------------------------------------------------------
*/
int
TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | | | | 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 |
*
*----------------------------------------------------------------------
*/
int
TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
* rep.
*/
if (objPtr->bytes == NULL) {
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
goto badBoolean;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
goto badBoolean;
}
}
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
2142 2143 2144 2145 2146 2147 2148 |
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (char *)NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
| | | 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 |
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", (char *)NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int newBool;
char lowerCase[6];
Tcl_Size i, length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
if ((length < 1) || (length > 5)) {
|
| ︙ | ︙ | |||
2247 2248 2249 2250 2251 2252 2253 |
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
| | | | 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 |
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = tclBooleanTypePtr;
return TCL_OK;
numericBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = tclIntTypePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewDoubleObj --
|
| ︙ | ︙ | |||
2284 2285 2286 2287 2288 2289 2290 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( | | | | 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 |
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
Tcl_Obj *objPtr;
TclNewDoubleObj(objPtr, dblValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj( | | | | | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = tclDoubleTypePtr;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
2381 2382 2383 2384 2385 2386 2387 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( | | | | 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetDoubleObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
double dblValue) /* Double used to set the object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj");
}
TclSetDoubleObj(objPtr, dblValue);
}
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 | * old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetDoubleFromObj( | | | | | | | | 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 |
* old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
(char *)NULL);
}
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
|
| ︙ | ︙ | |||
2469 2470 2471 2472 2473 2474 2475 |
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 |
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
NULL, 0);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2497 2498 2499 2500 2501 2502 2503 | * double-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfDouble( | | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 |
* double-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
TclOOM(dst, TCL_DOUBLE_SPACE + 1);
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
|
| ︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 | * representation. * *---------------------------------------------------------------------- */ int Tcl_GetIntFromObj( | | | | | 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 |
* representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a int. */
int *intPtr) /* Place to store resulting int. */
{
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
long l;
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
|
| ︙ | ︙ | |||
2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 |
}
return TCL_ERROR;
}
*intPtr = (int) l;
return TCL_OK;
#endif
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object to
| > > > > > > > > > > > > > | 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 |
}
return TCL_ERROR;
}
*intPtr = (int) l;
return TCL_OK;
#endif
}
int
ScalarObjInterfaceListLength(
TCL_UNUSED(Tcl_Interp *), /* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *), /* List object whose #elements to return. */ \
Tcl_Size *lenPtr /* The resulting length is stored here. */
)
{
*lenPtr = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object to
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 | * int-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfInt( | | | 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 |
* int-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
|
| ︙ | ︙ | |||
2642 2643 2644 2645 2646 2647 2648 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetLongFromObj( | | | | | | | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
do {
#ifdef TCL_WIDE_INT_IS_LONG
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#else
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
/*
* We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
* existing semantics for conversion of integers on input, but
* avoids inadvertent demotion of wide integers to 32-bit ones in
* the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= (Tcl_WideInt)(LONG_MIN)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = (long)w;
return TCL_OK;
}
goto tooLarge;
}
#endif
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
* long range get auto-narrowed to tclIntType, while all the
* values in the unsigned long range will fit in a long.
*/
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( | < | < | | 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 |
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewWideIntObj
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue) /* Wide integer used to initialize the new
* object. */
{
return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue) /* Wide integer used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclSetIntObj(objPtr, wideValue);
return objPtr;
|
| ︙ | ︙ | |||
2800 2801 2802 2803 2804 2805 2806 | * None. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_NewWideUIntObj( | | < | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewWideUIntObj(
Tcl_WideUInt uwideValue) /* Wide integer used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewUIntObj(objPtr, uwideValue);
return objPtr;
}
|
| ︙ | ︙ | |||
2846 2847 2848 2849 2850 2851 2852 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( | < | < | | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue, /* Wide integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue, /* Long integer used to initialize the new
* object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
2895 2896 2897 2898 2899 2900 2901 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( | | | < | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideIntObj(
Tcl_Obj *objPtr, /* Object w. internal rep to init. */
Tcl_WideInt wideValue) /* Wide integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
TclSetIntObj(objPtr, wideValue);
|
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideUIntObj( | | | < | 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 |
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideUIntObj(
Tcl_Obj *objPtr, /* Object w. internal rep to init. */
Tcl_WideUInt uwideValue) /* Wide integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideUIntObj");
}
if (uwideValue > WIDE_MAX) {
|
| ︙ | ︙ | |||
2970 2971 2972 2973 2974 2975 2976 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideIntFromObj( | | | | < | | | | > | 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 |
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */
{
do {
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt),
&numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
*wideIntPtr = (Tcl_WideInt)(-value);
return TCL_OK;
|
| ︙ | ︙ | |||
3055 3056 3057 3058 3059 3060 3061 | * any old internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetWideUIntFromObj( | | | | < | | | | > | 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 |
* any old internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideUIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr) /* Place to store resulting long. */
{
do {
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
if (objPtr->internalRep.wideValue < 0) {
wideUIntOutOfRange:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected unsigned integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
*wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
goto wideUIntOutOfRange;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideUInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideUInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (big.sign == MP_NEG) {
goto wideUIntOutOfRange;
}
if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt),
&numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
*wideUIntPtr = (Tcl_WideUInt)value;
return TCL_OK;
}
|
| ︙ | ︙ | |||
3140 3141 3142 3143 3144 3145 3146 | * conversion will free any old internal representation. * *---------------------------------------------------------------------- */ int TclGetWideBitsFromObj( | | | | | | | | 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 |
* conversion will free any old internal representation.
*
*----------------------------------------------------------------------
*/
int
TclGetWideBitsFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
{
do {
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
mp_int big;
mp_err err;
Tcl_WideUInt value = 0, scratch;
size_t numBytes;
unsigned char *bytes = (unsigned char *) &scratch;
|
| ︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 | * Side effects: * The function may free up any existing internal representation. * *---------------------------------------------------------------------- */ int Tcl_GetSizeIntFromObj( | | | | | 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 |
* Side effects:
* The function may free up any existing internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetSizeIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a int. */
Tcl_Size *sizePtr) /* Place to store resulting int. */
{
if (sizeof(Tcl_Size) == sizeof(int)) {
return TclGetIntFromObj(interp, objPtr, (int *)sizePtr);
} else {
Tcl_WideInt wide;
if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3271 3272 3273 3274 3275 3276 3277 |
DupBignum(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
| | | 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 |
DupBignum(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = tclBignumTypePtr;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
}
|
| ︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
| | | 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3466 3467 3468 3469 3470 3471 3472 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
| | | | 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (char *)NULL);
}
return TCL_ERROR;
|
| ︙ | ︙ | |||
3516 3517 3518 3519 3520 3521 3522 |
*----------------------------------------------------------------------
*/
int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
| | | 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 |
*----------------------------------------------------------------------
*/
int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
void *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3551 3552 3553 3554 3555 3556 3557 |
*----------------------------------------------------------------------
*/
int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
| | | 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 |
*----------------------------------------------------------------------
*/
int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
void *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3633 3634 3635 3636 3637 3638 3639 |
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
| | | | | < | | | | | | | | > > | | > | | 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 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 |
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = tclBignumTypePtr;
PACK_BIGNUM(*bignumValue, objPtr);
/*
* Clear the mp_int value.
*
* Don't call mp_clear() because it would free the digit array we just
* packed into the Tcl_Obj.
*/
bignumValue->dp = NULL;
bignumValue->alloc = bignumValue->used = 0;
bignumValue->sign = MP_NEG;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
* Results:
* A standard Tcl completion code. On success, the type is stored at the
* address given by typePtr, and a pointer to the representation is stored
* at the address given by clientDataPtr.
*
* Side effects:
* May allocate thread-specific data shared within a thread for handling
* the copy-out space for bignums.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
Tcl_Size length;
do {
if (TclHasInternalRep(objPtr, tclDoubleTypePtr)) {
if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclIntTypePtr)) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (TclHasInternalRep(objPtr, tclBignumTypePtr)) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
}
/* Handle dict separately, because it doesn't have a lengthProc */
if (TclHasInternalRep(objPtr, tclDictTypePtr)) {
Tcl_DictObjSize(NULL, objPtr, &length);
if (length > 1) {
listRep:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("expected number but got a list", -1));
}
return TCL_ERROR;
}
}
if (TclObjectHasInterface(objPtr ,list ,length)) {
int status;
status = Tcl_ListObjLength(interp ,objPtr ,&length);
if (!status && length != 1) {
goto listRep;
}
}
} while (TCL_OK ==
TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
/* Don't try to convert index or boolean's to a list */
if (!TclHasInternalRep(objPtr, &tclIndexType)
&& !TclHasInternalRep(objPtr, tclBooleanTypePtr)
&& (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) && (length > 1)) {
goto listRep;
}
return TCL_ERROR;
}
int
|
| ︙ | ︙ | |||
3779 3780 3781 3782 3783 3784 3785 | * *---------------------------------------------------------------------- */ #undef Tcl_IncrRefCount void Tcl_IncrRefCount( | | > | > | 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 |
*
*----------------------------------------------------------------------
*/
#undef Tcl_IncrRefCount
void
Tcl_IncrRefCount(
Tcl_Obj *objPtr) /* The object we are registering a reference
* to. */
{
++(objPtr)->refCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DecrRefCount --
*
* Decrements the reference count of the object.
*
* Results:
* The storage for objPtr may be freed.
*
*----------------------------------------------------------------------
*/
#undef Tcl_DecrRefCount
void
Tcl_DecrRefCount(
Tcl_Obj *objPtr) /* The object we are releasing a reference
* to. */
{
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
/*
|
| ︙ | ︙ | |||
3822 3823 3824 3825 3826 3827 3828 | * possibly with a refCount of 0. The caller must have previously * incremented the refCount. * *---------------------------------------------------------------------- */ void TclUndoRefCount( | | > | 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 |
* possibly with a refCount of 0. The caller must have previously
* incremented the refCount.
*
*----------------------------------------------------------------------
*/
void
TclUndoRefCount(
Tcl_Obj *objPtr) /* The object we are releasing a reference
* to. */
{
if (objPtr->refCount > 0) {
--objPtr->refCount;
}
}
/*
|
| ︙ | ︙ | |||
3845 3846 3847 3848 3849 3850 3851 | * *---------------------------------------------------------------------- */ #undef Tcl_IsShared int Tcl_IsShared( | | | 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 |
*
*----------------------------------------------------------------------
*/
#undef Tcl_IsShared
int
Tcl_IsShared(
Tcl_Obj *objPtr) /* The object to test for being shared. */
{
return ((objPtr)->refCount > 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3874 3875 3876 3877 3878 3879 3880 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( | | | 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == FREEDREFCOUNTFILLER) {
|
| ︙ | ︙ | |||
3914 3915 3916 3917 3918 3919 3920 |
}
# endif /* TCL_THREADS */
++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbIncrRefCount(
| | | 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 |
}
# endif /* TCL_THREADS */
++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
++(objPtr)->refCount;
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
3947 3948 3949 3950 3951 3952 3953 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( | | | 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == FREEDREFCOUNTFILLER) {
|
| ︙ | ︙ | |||
3990 3991 3992 3993 3994 3995 3996 |
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbDecrRefCount(
| | | 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 |
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
|
| ︙ | ︙ | |||
4024 4025 4026 4027 4028 4029 4030 | * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared( | | | 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
#ifdef TCL_MEM_DEBUG
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
#else
TCL_UNUSED(const char *) /*file*/,
|
| ︙ | ︙ | |||
4101 4102 4103 4104 4105 4106 4107 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( | < | | 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitObjHashTable(
Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied
* by the caller. */
{
Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
&tclObjHashKeyType);
}
/*
|
| ︙ | ︙ | |||
4324 4325 4326 4327 4328 4329 4330 |
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
| | | 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 |
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
Tcl_Obj *objPtr) /* The object containing the command's name.
* If the name starts with "::", will be
* looked up in global namespace. Else, looked
* up first in the current namespace, then in
* global namespace. */
{
ResolvedCmdName *resPtr;
|
| ︙ | ︙ | |||
4460 4461 4462 4463 4464 4465 4466 |
}
}
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
| | | 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 |
}
}
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
if (TclHasInternalRep(objPtr, &tclCmdNameType)) {
|
| ︙ | ︙ | |||
4500 4501 4502 4503 4504 4505 4506 | * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( | | | 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 |
* ResolvedSymbol, which may free the Command structure.
*
*----------------------------------------------------------------------
*/
static void
FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
|
| ︙ | ︙ | |||
4548 4549 4550 4551 4552 4553 4554 |
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 |
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
resPtr->refCount++;
copyPtr->typePtr = &tclCmdNameType;
}
static int
ScalarObjIndex(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
Tcl_Obj *listPtr, /* List object to index into. */ \
Tcl_Size index, /* Index of element to return. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
) {
if (index == 0) {
*resPtrPtr = listPtr;
} else {
*resPtrPtr = NULL;
}
return TCL_OK;
}
static int ScalarObjRange(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors */ \
Tcl_Obj *listPtr, /* List object to take a range from. */ \
Tcl_Size rangeStart, /* Index of first element to */ \
/* include. */ \
Tcl_Size rangeEnd, /* Index of last element to include. */
Tcl_Obj **resPtrPtr
)
{
if (rangeEnd >= 0 && rangeEnd >= rangeStart) {
*resPtrPtr = listPtr;
} else {
*resPtrPtr = NULL;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetCmdNameFromAny --
*
* Generate an cmdName internal form for the Tcl object "objPtr".
|
| ︙ | ︙ | |||
4582 4583 4584 4585 4586 4587 4588 |
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 |
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
const char *name;
Command *cmdPtr;
ResolvedCmdName *resPtr;
if (interp == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
4669 4670 4671 4672 4673 4674 4675 |
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "1872361827361287"
*/
| > > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "1872361827361287"
*/
const char *name = objv[1]->typePtr
? TclObjTypeName(objv[1]->typePtr)
: "pure string";
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %"
TCL_SIZE_MODIFIER "d," " object pointer at %p"
,name
,objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
if (TclHasInternalRep(objv[1], tclDoubleTypePtr)) {
Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
objv[1]->internalRep.doubleValue);
} else {
Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
(void *) objv[1]->internalRep.twoPtrValue.ptr1,
(void *) objv[1]->internalRep.twoPtrValue.ptr2);
}
}
if (objv[1]->bytes) {
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;
}
void Tcl_ObjTypeVersion(Tcl_Obj *objPtr, int *version) {
if ((void *)objPtr->typePtr->name == (void *)&TclObjectTypeType0) {
*version = ((ObjectType *)objPtr->typePtr)->version;
} else {
*version = 1;
}
return;
}
TclObjectTypeType * TclGetObjectTypeType () {
return &TclObjectTypeType0;
}
int (*TclObjInterfaceGetListIndex (Tcl_Obj *objPtr))
(tclObjTypeInterfaceArgsListIndex)
{
ObjInterface *ifPtr = TclObjInterface(objPtr);
if (ifPtr->version >= 1) {
return ifPtr->list.index;
}
return NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 2024 Nathan Coulter. All rights reserved.
*
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
*----------------------------------------------------------------------
* Tcl_NewObjInterface
*----------------------------------------------------------------------
*/
#include "tcl.h"
#include "tclInt.h"
Tcl_ObjInterface *
Tcl_NewObjInterface() {
ObjInterface * ifacePtr;
ifacePtr = (ObjInterface *)Tcl_Alloc(sizeof(ObjInterface));
memset(ifacePtr ,0 ,sizeof(ObjInterface));
return (Tcl_ObjInterface *)ifacePtr;
}
Tcl_ObjType *
Tcl_NewObjType(
) {
ObjectType *objTypePtr;
objTypePtr = (ObjectType *)Tcl_Alloc(sizeof(ObjectType));
return (Tcl_ObjType *)objTypePtr;
}
int
Tcl_ObjInterfaceSetFnListAll(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListAllProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.all = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListAppend(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListAppendProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.append = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListAppendList(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListAppendlistProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.appendlist = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListContains(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListContainsProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.contains = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListIndex(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListIndexProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.index = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListIndexEnd(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListIndexEndProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.indexEnd = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListIsSorted(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListIsSortedProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.isSorted = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListLength(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListLengthProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.length = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListRange(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListRangeProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.range = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListRangeEnd(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListRangeEndProc fnPtr
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.rangeEnd = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListReplace(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListReplaceProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.replace = fnPtr;
return TCL_OK;
}
int Tcl_ObjInterfaceSetFnListReplaceList(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListReplaceListProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.replaceList = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListReverse(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListReverseProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.reverse = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListSet(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListSetProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.set = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnListSetDeep(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceListSetDeepProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->list.setDeep = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringIndex(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringIndexProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.index = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringIndexEnd(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringIndexEndProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.indexEnd = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringIsEmpty(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringIsEmptyProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.isEmpty = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringLength(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringLengthProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.length = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringRange(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringRangeProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.range = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetFnStringRangeEnd(
Tcl_ObjInterface *objInterfacePtr
,Tcl_ObjInterfaceStringRangeEndProc fnPtr)
{
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->string.rangeEnd = fnPtr;
return TCL_OK;
}
int
Tcl_ObjInterfaceSetVersion(
Tcl_ObjInterface *objInterfacePtr
,int version
) {
ObjInterface *oiPtr = (ObjInterface *)objInterfacePtr;
oiPtr->version = version;
return TCL_OK;
}
int
Tcl_ObjTypeSetFreeInternalRepProc(
Tcl_ObjType *otPtr
,Tcl_FreeInternalRepProc *freeIntRepProc
) {
otPtr->freeIntRepProc = freeIntRepProc;
return TCL_OK;
}
int
Tcl_ObjTypeSetDupInternalRepProc(
Tcl_ObjType *otPtr
,Tcl_DupInternalRepProc *dupIntRepProc)
{
otPtr->dupIntRepProc = dupIntRepProc;
return TCL_OK;
}
int
Tcl_ObjTypeSetInterface(
Tcl_ObjType *objTypePtr
,Tcl_ObjInterface * objInterfacePtr)
{
ObjectType *otPtr = (ObjectType *)objTypePtr;
otPtr->ifPtr = objInterfacePtr;
return TCL_OK;
}
int
Tcl_ObjTypeSetUpdateStringProc(
Tcl_ObjType *otPtr
,Tcl_UpdateStringProc *updateStringProc)
{
otPtr->updateStringProc = updateStringProc;
return TCL_OK;
}
int
Tcl_ObjTypeSetSetFromAnyProc(
Tcl_ObjType *otPtr
,Tcl_SetFromAnyProc *setFromAnyProc)
{
otPtr->setFromAnyProc = setFromAnyProc;
return TCL_OK;
}
int
Tcl_ObjTypeSetName(
Tcl_ObjType *otPtr
,char *name)
{
otPtr->name = name;
return TCL_OK;
}
int
Tcl_ObjTypeSetVersion(
Tcl_ObjType *otPtr
,int version)
{
otPtr->version = version;
return TCL_OK;
}
|
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2013 Donal Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclOptimize.c -- * * This file contains the bytecode optimizer. */ #include "tclInt.h" #include "tclCompile.h" #include <assert.h> /* * Forward declarations. */ |
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
| | | | 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 |
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
(void) Tcl_GetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
case INST_PUSH4:
if (nextInst == INST_POP) {
blank = size + 1;
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt4AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
(void) Tcl_GetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
case INST_LNOT:
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1988-1993 The Regents of the University of California.
* Copyright © 1994 Sun Microsystems, Inc.
* Copyright © 1998-1999 Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclPanic.c --
*
* Source code for the "Tcl_Panic" library procedure for Tcl; individual
* applications will probably call Tcl_SetPanicProc() to set an
* application-specific panic procedure.
*/
#include "tclInt.h"
#if defined(_WIN32) || defined(__CYGWIN__)
MODULE_SCOPE void tclWinDebugPanic(const char *format, ...);
#endif
/*
* The panicProc variable contains a pointer to an application specific panic
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclParse.c -- * * This file contains functions that parse Tcl scripts. They do so in a * general-purpose fashion that can be used for many different purposes, * including compilation, direct execution, code analysis, etc. */ #include "tclInt.h" #include "tclParse.h" #include <assert.h> /* * The following table provides parsing information about each possible 8-bit * character. The table is designed to be referenced with unsigned characters. |
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the script consists of all bytes up to the
* first null character. */
int nested, /* Non-zero means this is a nested command:
* close bracket should be considered a
* command terminator. If zero, then close
* bracket has no special meaning. */
| < | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 |
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the script consists of all bytes up to the
* first null character. */
int nested, /* Non-zero means this is a nested command:
* close bracket should be considered a
* command terminator. If zero, then close
* bracket has no special meaning. */
Tcl_Parse *parsePtr) /* Structure to fill in with information about
* the parsed command; any previous
* information in the structure is ignored. */
{
const char *src; /* Points to current character in the
* command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
} else if ((tokenPtr->numComponents == 1)
&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
/* Parse the whitespace between words. */
| | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
} else if ((tokenPtr->numComponents == 1)
&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
}
/* Parse the whitespace between words. */
scanned = ParseWhiteSpace(src, numBytes, &parsePtr->incomplete, &type);
src += scanned;
numBytes -= scanned;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 | src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; ch = *src; | | | > > | > > > | | | 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 |
src++;
numBytes--;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
ch = *src;
while (numBytes && (braceCount > 0 || ch != '}')) {
switch (ch) {
case '{':
braceCount++;
break;
case '}':
braceCount--;
break;
case '\\':
/* if 2 or more left, consume 2, else consume
* just the \ and let it run into the end */
if (numBytes > 1) {
src++;
numBytes--;
}
}
numBytes--;
src++;
ch= *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;
tokenPtr[-1].size = src - tokenPtr[-1].start;
parsePtr->numTokens++;
src++;
|
| ︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 |
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
| < | | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 |
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr, /* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 |
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
| < | | 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 |
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
Tcl_Size numBytes, /* Total number of bytes in string. If -1,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr, /* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
|
| ︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 |
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
Tcl_Size clPos;
if (result == 0) {
clPos = 0;
} else {
| | | 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 |
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
Tcl_Size clPos;
if (result == 0) {
clPos = 0;
} else {
(void)Tcl_GetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (Tcl_Size *)Tcl_Realloc(clPosition,
maxNumCL * sizeof(Tcl_Size));
}
|
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 |
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
Tcl_Size length;
| | | 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 |
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
Tcl_Size length;
const char *script = Tcl_GetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 2 3 4 5 6 7 |
/*
* Minimal set of shared flag definitions and declarations so that multiple
* source files can make use of the parsing table in tclParse.c
*/
enum ParseTypeFlags {
TYPE_NORMAL = 0,
| > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* Minimal set of shared flag definitions and declarations so that multiple
* source files can make use of the parsing table in tclParse.c
*/
enum ParseTypeFlags {
TYPE_NORMAL = 0,
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclPathObj.c -- * * This file contains the implementation of Tcl's "path" object type used * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2003 Vince Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPathObj.c -- * * This file contains the implementation of Tcl's "path" object type used * to represent and manipulate a general (virtual) filesystem entity in * an efficient manner. */ #include "tclInt.h" #include "tclFileSystem.h" #include <assert.h> /* |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny, /* setFromAnyProc */
| < > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
static const Tcl_ObjType fsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny, /* setFromAnyProc */
0
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of fsPathType
*/
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | /* * Define some macros to give us convenient access to path-object specific * fields. */ #define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
/*
* Define some macros to give us convenient access to path-object specific
* fields.
*/
#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1))
#define SETPATHOBJ(pathPtr, fsPathPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \
ir.twoPtrValue.ptr2 = NULL; \
Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \
} while (0)
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 |
if (zipVolumeLen) {
/*
* NOTE: file normalization for zipfs is very specific to
* format of zipfs volume being of the form //xxx:/
*/
dirSep += zipVolumeLen-1; /* Start parse after : */
} else if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | | | | | | | | 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 |
if (zipVolumeLen) {
/*
* NOTE: file normalization for zipfs is very specific to
* format of zipfs volume being of the form //xxx:/
*/
dirSep += zipVolumeLen-1; /* Start parse after : */
} else if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if ((dirSep[0] == '/' || dirSep[0] == '\\')
&& (dirSep[1] == '/' || dirSep[1] == '\\')
&& (dirSep[2] == '?')
&& (dirSep[3] == '/' || dirSep[3] == '\\')) {
/* NT extended path */
dirSep += 4;
if ((dirSep[0] == 'U' || dirSep[0] == 'u')
&& (dirSep[1] == 'N' || dirSep[1] == 'n')
&& (dirSep[2] == 'C' || dirSep[2] == 'c')
&& (dirSep[3] == '/' || dirSep[3] == '\\')) {
/* NT extended UNC path */
dirSep += 4;
}
}
if (dirSep[0] != 0 && dirSep[1] == ':' &&
(dirSep[2] == '/' || dirSep[2] == '\\')) {
/* Do nothing */
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
Tcl_Size curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
| | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
Tcl_Size curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
dirSep += 2;
oldDirSep = dirSep;
if (dirSep[0] != 0 && dirSep[1] == '.') {
goto again;
|
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
(void)Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
if (zipVolumeLen) {
linkObj = NULL;
} else {
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 | /* * We need to follow this link which is relative * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ const char *path = | | | | | | 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 |
/*
* We need to follow this link which is relative
* to retVal's directory. This means concatenating
* the link onto the directory of the path so far.
*/
const char *path =
Tcl_GetStringFromObj(retVal, &curLen);
while (curLen-- > 0) {
if (IsSeparatorOrNull(path[curLen])) {
break;
}
}
/*
* We want the trailing slash.
*/
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
*/
TclDecrRefCount(retVal);
if (Tcl_IsShared(linkObj)) {
retVal = Tcl_DuplicateObj(linkObj);
TclDecrRefCount(linkObj);
} else {
retVal = linkObj;
}
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
Tcl_Size i;
for (i = 0; i < curLen; i++) {
if (linkStr[i] == '\\') {
linkStr[i] = '/';
}
}
}
}
} else {
linkStr = Tcl_GetStringFromObj(retVal, &curLen);
}
/*
* Either way, we now remove the last path element (but
* not the first character of the path). In the case of
* zipfs, make sure not to go beyond the zipfs volume.
*/
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
/*
* Ensure a windows drive like C:/ has a trailing separator.
* Likewise for zipfs volumes.
*/
if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
int needTrailingSlash = 0;
Tcl_Size len;
| | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
/*
* Ensure a windows drive like C:/ has a trailing separator.
* Likewise for zipfs volumes.
*/
if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
int needTrailingSlash = 0;
Tcl_Size len;
const char *path = Tcl_GetStringFromObj(retVal, &len);
if (zipVolumeLen) {
if (len == (zipVolumeLen - 1)) {
needTrailingSlash = 1;
}
} else {
if (len == 2 && path[0] != 0 && path[1] == ':') {
needTrailingSlash = 1;
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | * 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 * the standardPath code. */ Tcl_Size numBytes; | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
* 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
* the standardPath code.
*/
Tcl_Size numBytes;
const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file dirname] is
* documented to return all but the last non-empty element
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | * Check if the joined-on bit has any directory delimiters in * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ Tcl_Size numBytes; | | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'tail' would be only the part following the
* last delimiter. We could handle that special case here, but
* we don't, and instead just use the standardPath code.
*/
Tcl_Size numBytes;
const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file tail] is
* documented to return the last non-empty element
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
Tcl_Size length;
| | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
Tcl_Size length;
fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
/*
* There is no extension so the root is the same as the
* path we were given.
*/
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 |
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
Tcl_Size length;
const char *fileName, *extension;
| | | 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
Tcl_Size length;
const char *fileName, *extension;
fileName = Tcl_GetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
return pathPtr;
} else {
Tcl_Obj *root = Tcl_NewStringObj(fileName,
length - strlen(extension));
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | * Tcl_FSSplitPath preserves the "~", but this code computes the * actual full path name, if we had just a single component. */ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); | | | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
* Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
Tcl_IncrRefCount(splitPtr);
if (portion == TCL_PATH_TAIL) {
/*
* Return the last component, unless it is the only component, and
* it is the root of an absolute path.
*/
if ((splitElements > 0) && ((splitElements > 1) ||
(Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
Tcl_Size len;
| | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
Tcl_Size len;
str = Tcl_GetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
* There's no need to return a special path object, when
* the base itself is just fine!
*/
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 | Tcl_Size driveNameLength; Tcl_Size strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
Tcl_Size driveNameLength;
Tcl_Size strEltLen, length;
Tcl_PathType type;
char *strElt, *ptr;
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
/* if forceRelative - all paths excepting first one are relative */
type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE :
TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/*
* Zero out the current result.
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 |
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
| | | | | 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
* We need to perform a more complex operation here.
*/
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
ptr = Tcl_GetStringFromObj(res, &length);
/*
* A NULL value for fsPtr at this stage basically means we're trying
* to join a relative path onto something which is also relative (or
* empty). There's nothing particularly wrong with that.
*/
if (*strElt == '\0') {
continue;
}
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
| | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
(void)Tcl_GetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + strlen(strElt));
ptr = TclGetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
|
| ︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 |
* This is likely buggy when dealing with virtual filesystem drivers
* that use some character other than "/" as a path separator. I know
* of no evidence that such a foolish thing exists. This solution was
* chosen so that "JoinPath" operations that pass through either path
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
| | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
* This is likely buggy when dealing with virtual filesystem drivers
* that use some character other than "/" as a path separator. I know
* of no evidence that such a foolish thing exists. This solution was
* chosen so that "JoinPath" operations that pass through either path
* internalrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
bytes = Tcl_GetStringFromObj(tail, &length);
if (length == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
TclpNativeJoinPath(copy, bytes);
}
return copy;
}
|
| ︙ | ︙ | |||
1408 1409 1410 1411 1412 1413 1414 |
* better test than the '!= sep' might be to simply check if 'cwd' is a
* root volume.
*
* Note that if we get this wrong, we will strip off either too much or
* too little below, leading to wrong answers returned by glob.
*/
| | | | 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 |
* better test than the '!= sep' might be to simply check if 'cwd' is a
* root volume.
*
* Note that if we get this wrong, we will strip off either too much or
* too little below, leading to wrong answers returned by glob.
*/
tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the
* Windows special case? Perhaps we should just check if cwd is a root
* volume.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (tempStr[cwdLen-1] != '/') {
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
}
tempStr = Tcl_GetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 |
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
Tcl_Size len;
| | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
Tcl_Size len;
const char *orig = Tcl_GetStringFromObj(transPtr, &len);
char *result = (char *)Tcl_Alloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
|
| ︙ | ︙ | |||
1713 1714 1715 1716 1717 1718 1719 |
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
| | | | 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 |
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
(void)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'
*/
(void) Tcl_GetStringFromObj(dir, &cwdLen);
/* Normalize the combined string. */
if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) {
/*
* If the "tail" part has components (like /../) that cause the
* combined path to need more complete normalizing, call on the
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 |
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
Tcl_Size cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
| | | 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 |
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
Tcl_Size cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
(void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (TclGetString(copy)[cwdLen] == '/');
/*
* Normalize the combined string, but only starting after the end
* of the previously normalized 'dir'. This should be much faster!
*/
|
| ︙ | ︙ | |||
2147 2148 2149 2150 2151 2152 2153 |
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
| | | | | | 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 |
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
return 1;
}
/*
* Try the most thorough, correct method of comparing fully normalized
* paths.
*/
tempErrno = Tcl_GetErrno();
firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
Tcl_SetErrno(tempErrno);
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
|
| ︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 |
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and one has to make
* sure not to break anything on Unix or Win (fCmd.test, fileName.test and
* cmdAH.test exercise most of the code).
*/
| | | 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 |
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and one has to make
* sure not to break anything on Unix or Win (fCmd.test, fileName.test and
* cmdAH.test exercise most of the code).
*/
Tcl_GetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
transPtr = TclJoinPath(1, &pathPtr, 1);
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
|
| ︙ | ︙ | |||
2365 2366 2367 2368 2369 2370 2371 |
if (Tcl_IsShared(copy)) {
copy = Tcl_DuplicateObj(copy);
}
Tcl_IncrRefCount(copy);
/* Steal copy's string rep */
| | | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 |
if (Tcl_IsShared(copy)) {
copy = Tcl_DuplicateObj(copy);
}
Tcl_IncrRefCount(copy);
/* Steal copy's string rep */
pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
TclInitEmptyStringRep(copy);
TclDecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 | * It is somewhat unusual to reach this code path without the object * being of fsPathType. However, we do our best to deal with the * situation. */ Tcl_Size len; | | | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 |
* It is somewhat unusual to reach this code path without the object
* being of fsPathType. However, we do our best to deal with the
* situation.
*/
Tcl_Size len;
(void) Tcl_GetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
*/
return -1;
}
|
| ︙ | ︙ | |||
2447 2448 2449 2450 2451 2452 2453 | } /* *---------------------------------------------------------------------- * * MakeTildeRelativePath -- * | | | | 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 | } /* *---------------------------------------------------------------------- * * MakeTildeRelativePath -- * * Returns a path relative to the home directory of a user. * Note there is a difference between not specifying a user and * explicitly specifying the current user. This mimics Tcl8's tilde * expansion. * * The subPath argument is joined to the expanded home directory * as in Tcl_JoinPath. This means if it is not relative, it will * returned as the result with the home directory only checked * for user name validity. |
| ︙ | ︙ | |||
2478 2479 2480 2481 2482 2483 2484 |
const char *dir;
Tcl_DString dirString;
Tcl_DStringInit(dsPtr);
Tcl_DStringInit(&dirString);
if (user == NULL || user[0] == 0) {
| | | | | | | | | | | | | | | | | | 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 |
const char *dir;
Tcl_DString dirString;
Tcl_DStringInit(dsPtr);
Tcl_DStringInit(&dirString);
if (user == NULL || user[0] == 0) {
/* No user name specified -> current user */
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't find HOME environment variable to expand path",
-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
"HOMELESS", (void *)NULL);
}
return TCL_ERROR;
}
} else {
/* User name specified - ~user */
dir = TclpGetUserHome(user, &dirString);
if (dir == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"user \"%s\" doesn't exist", user));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
(void *)NULL);
}
return TCL_ERROR;
}
}
if (subPath) {
const char *parts[2];
parts[0] = dir;
parts[1] = subPath;
Tcl_JoinPath(2, parts, dsPtr);
|
| ︙ | ︙ | |||
2526 2527 2528 2529 2530 2531 2532 | *---------------------------------------------------------------------- * * TclGetHomeDirObj -- * * Wrapper around MakeTildeRelativePath. See that function. * * Results: | | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
*----------------------------------------------------------------------
*
* TclGetHomeDirObj --
*
* Wrapper around MakeTildeRelativePath. See that function.
*
* Results:
* Returns a Tcl_Obj containing the home directory of a user
* or NULL on failure with error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetHomeDirObj(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
|
| ︙ | ︙ | |||
2555 2556 2557 2558 2559 2560 2561 | * * If the passed path is begins with a tilde, does tilde resolution * and returns a Tcl_Obj containing the resolved path. If the tilde * component cannot be resolved, returns NULL. If the path does not * begin with a tilde, returns as is. * * Results: | | | | | | | | | | | | 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 |
*
* If the passed path is begins with a tilde, does tilde resolution
* and returns a Tcl_Obj containing the resolved path. If the tilde
* component cannot be resolved, returns NULL. If the path does not
* begin with a tilde, returns as is.
*
* Results:
* Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj
* with ref count 0 or that pathObj that was passed in without its
* ref count modified.
* Returns NULL if the path begins with a ~ that cannot be resolved
* and stores an error message in interp if non-NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclResolveTildePath(
Tcl_Interp *interp, /* May be NULL. Only used for error messages */
Tcl_Obj *pathObj)
{
const char *path;
Tcl_Size len;
Tcl_Size split;
Tcl_DString resolvedPath;
path = Tcl_GetStringFromObj(pathObj, &len);
if (path[0] != '~') {
return pathObj;
}
/*
* We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
* split becomes value 1 for '~/...' as well as for '~'. Note on
* Windows FindSplitPos will implicitly check for '\' as separator
* in addition to what is passed.
*/
split = FindSplitPos(path, '/');
if (split == 1) {
/* No user name specified -> current user */
if (MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL,
&resolvedPath) != TCL_OK) {
return NULL;
}
} else {
/* User name specified - ~user */
const char *expandedUser;
Tcl_DString userName;
Tcl_DStringInit(&userName);
Tcl_DStringAppend(&userName, path+1, split-1);
expandedUser = Tcl_DStringValue(&userName);
/* path[split] is / or \0 */
if (MakeTildeRelativePath(interp, expandedUser,
path[split] ? &path[split+1] : NULL,
&resolvedPath) != TCL_OK) {
Tcl_DStringFree(&userName);
return NULL;
|
| ︙ | ︙ | |||
2622 2623 2624 2625 2626 2627 2628 | * * TclResolveTildePathList -- * * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing * the paths with any ~-prefixed paths resolved. * * Empty strings and ~-prefixed paths that cannot be resolved are | | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 | * * TclResolveTildePathList -- * * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing * the paths with any ~-prefixed paths resolved. * * Empty strings and ~-prefixed paths that cannot be resolved are * removed from the returned list. * * The trailing components of the path are returned verbatim. No * processing is done on them. Moreover, no assumptions should be * made about the separators in the returned path. They may be / * or native. Appropriate path manipulations functions should be * used by caller if desired. * * Results: * Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with |
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 |
Tcl_Obj **objv;
Tcl_Size objc;
Tcl_Size i;
Tcl_Obj *resolvedPaths;
const char *path;
if (pathsObj == NULL) {
| | | | | | | | | | | 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 |
Tcl_Obj **objv;
Tcl_Size objc;
Tcl_Size i;
Tcl_Obj *resolvedPaths;
const char *path;
if (pathsObj == NULL) {
return NULL;
}
if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) {
return NULL; /* Not a list */
}
/*
* Figure out if any paths need resolving to avoid unnecessary allocations.
*/
for (i = 0; i < objc; ++i) {
path = Tcl_GetString(objv[i]);
if (path[0] == '~') {
break; /* At least one path needs resolution */
}
}
if (i == objc) {
return pathsObj; /* No paths needed to be resolved */
}
resolvedPaths = Tcl_NewListObj(objc, NULL);
for (i = 0; i < objc; ++i) {
Tcl_Obj *resolvedPath;
path = Tcl_GetString(objv[i]);
if (path[0] == 0) {
continue; /* Skip empty strings */
}
resolvedPath = TclResolveTildePath(NULL, objv[i]);
if (resolvedPath) {
/* Paths that cannot be resolved are skipped */
Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath);
}
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPipe.c -- * * This file contains the generic portion of the command channel driver * as well as various utility routines used in managing subprocesses. */ #include "tclInt.h" /* * A linked list of the following structures is used to keep track of child * processes that have been detached but haven't exited yet, so we can make * sure that they're properly "reaped" (officially waited for) and don't lie * around as zombies cluttering the system. |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996 Sun Microsystems, Inc. * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Copyright © 2017 Nathan Coulter * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPkg.c -- * * This file implements package and version control for Tcl via the * "package" command and a few C APIs. */ /* * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. */ #include "tclInt.h" |
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); | | > | > | > | > | > | > > | > | > | > | | | | | | | 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 |
static int SomeRequirementSatisfied(char *havei, int reqc,
Tcl_Obj *const reqv[]);
static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
Tcl_Obj *const reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *const reqv[]);
static Package * FindPackage(Tcl_Interp *interp, const char *name);
static int PkgRequireCore(void *data[], Tcl_Interp *interp,
int result);
static int PkgRequireCoreFinal(void *data[], Tcl_Interp *interp,
int result);
static int PkgRequireCoreCleanup(void *data[], Tcl_Interp *interp,
int result);
static int PkgRequireCoreStep1(void *data[], Tcl_Interp *interp,
int result);
static int PkgRequireCoreStep2(void *data[], Tcl_Interp *interp,
int result);
static int TclNRPkgRequireProc(void *clientData,
Tcl_Interp *interp, int reqc,
Tcl_Obj *const reqv[]);
static int SelectPackage(void *data[], Tcl_Interp *interp,
int result);
static int SelectPackageFinal(void *data[], Tcl_Interp *interp,
int result);
static int TclNRPackageObjCmdCleanup(void *data[],
Tcl_Interp *interp, int result);
/*
* Helper macros.
*/
#define DupBlock(var, str, len) \
((var) = (char *) Tcl_Alloc(len), memcpy((var), (str), (len)))
#define DupString(var, str) \
do { \
size_t local__len = strlen(str) + 1; \
DupBlock((var), (str), local__len); \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_PkgProvide / Tcl_PkgProvideEx --
*
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 |
Tcl_Free(argv3i);
return TCL_OK;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
Tcl_Free(argv3i);
return TCL_OK;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
Tcl_Free(argv3i);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1222 1223 1224 1225 1226 1227 1228 |
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
if (iPtr->scriptFile) {
| | | | | 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 |
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
if (iPtr->scriptFile) {
argv4 = Tcl_GetStringFromObj(iPtr->scriptFile, &length);
DupBlock(availPtr->pkgIndex, argv4, length + 1);
}
argv4 = Tcl_GetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, length + 1);
break;
}
case PKG_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultObj;
TclNewObj(resultObj);
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
(char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, resultObj);
}
break;
case PKG_PRESENT: {
|
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 | objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, | | | 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 |
objvListPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(objvListPtr);
Tcl_ListObjAppendElement(interp, objvListPtr, ov);
TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv3, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
} else {
Tcl_Obj *const *newobjv = objv + 3;
|
| ︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 | */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, | | | | 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 |
*/
Tcl_ListObjAppendElement(interp, objvListPtr,
Tcl_DuplicateObj(newobjv[i]));
}
TclListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
Tcl_NRAddCallback(interp,
TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
}
break;
case PKG_UNKNOWN: {
Tcl_Size length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
Tcl_Free(iPtr->packageUnknown);
}
argv2 = Tcl_GetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, length+1);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
|
| ︙ | ︙ | |||
2067 2068 2069 2070 2071 2072 2073 |
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
Tcl_Size length;
for (i = 0; i < reqc; i++) {
| | | 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 |
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
Tcl_Size 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);
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2002 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPkgConfig.c -- * * This file contains the configuration information to embed into the tcl * library. */ /* Note, the definitions in this module are influenced by the following C * preprocessor macros: * * OSCMa = shortcut for "old style configuration macro activates" * NSCMdt = shortcut for "new style configuration macro declares that" * * - TCL_THREADS OSCMa compilation as threaded core. |
| ︙ | ︙ |
1 2 3 4 | /* * tclPlatDecls.h -- * * Declarations of platform specific Tcl APIs. | > > > > > > > > > > > > > > < < < | 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) 1998-1999 by Scriptics Corporation. * All rights reserved. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPlatDecls.h -- * * Declarations of platform specific Tcl APIs. */ #ifndef _TCLPLATDECLS #define _TCLPLATDECLS #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 |
# ifdef __cplusplus
# define MODULE_SCOPE extern "C"
# else
# define MODULE_SCOPE extern
# endif
#endif
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
/* Slot 0 is reserved */
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
Tcl_Size hasResourceFile,
Tcl_Size maxPathLen, char *libraryPath);
/* 2 */
EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
/* 3 */
EXTERN void Tcl_WinConvertError(unsigned errCode);
typedef struct TclPlatStubs {
int magic;
void *hooks;
void (*reserved0)(void);
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, Tcl_Size hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */
void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */
void (*tcl_WinConvertError) (unsigned errCode); /* 3 */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ #define Tcl_WinConvertError \ (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ | < < < > > > > > > > > > > | < | 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 | (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ #define Tcl_WinConvertError \ (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #ifdef _WIN32 # undef Tcl_CreateFileHandler # undef Tcl_DeleteFileHandler # undef Tcl_GetOpenFile #endif #ifndef MAC_OSX_TCL # undef Tcl_MacOSXOpenVersionedBundleResources # undef Tcl_MacOSXNotifierAddRunLoopMode #endif #ifdef _WIN32 # undef Tcl_CreateFileHandler # undef Tcl_DeleteFileHandler # undef Tcl_GetOpenFile #endif #ifndef MAC_OSX_TCL # undef Tcl_MacOSXOpenVersionedBundleResources # undef Tcl_MacOSXNotifierAddRunLoopMode #endif #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__)) #undef Tcl_WinUtfToTChar #undef Tcl_WinTCharToUtf #ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif #endif #endif /* _TCLPLATDECLS */ |
1 2 3 4 5 6 | /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. */ #ifndef _TCLPORT #define _TCLPORT #ifdef HAVE_TCL_CONFIG_H #include "tclConfig.h" |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPosixStr.c -- * * This file contains procedures that generate strings corresponding to * various POSIX-related codes, such as errno and signals. */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_ErrnoId -- * |
| ︙ | ︙ | |||
520 521 522 523 524 525 526 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_ErrnoMsg( | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ErrnoMsg(
int err) /* Error number (such as in errno variable). */
{
switch (err) {
#if defined(E2BIG) && (!defined(EOVERFLOW) || (E2BIG != EOVERFLOW))
case E2BIG: return "argument list too long";
#endif
#ifdef EACCES
case EACCES: return "permission denied";
|
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalId( | | | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_SignalId(
int sig) /* Number of signal. */
{
switch (sig) {
#ifdef SIGABRT
case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
case SIGALRM: return "SIGALRM";
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_SignalMsg( | | | 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_SignalMsg(
int sig) /* Number of signal. */
{
switch (sig) {
#ifdef SIGABRT
case SIGABRT: return "SIGABRT";
#endif
#ifdef SIGALRM
case SIGALRM: return "alarm clock";
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclPreserve.c -- * * This file contains a collection of functions that are used to make * sure that widget records and other data structures aren't reallocated * when there are nested functions that depend on their existence. */ #include "tclInt.h" /* * The following data structure is used to keep track of all the Tcl_Preserve * calls that are still in effect. It grows as needed to accommodate any * number of calls in effect. */ |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2004-2006 Miguel Sofer * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * Copyright © 2024 Nathan Coulter * * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, including * the "proc" and "uplevel" commands. */ #include "tclInt.h" #include "tclCompile.h" #include <assert.h> /* * Variables that are part of the [apply] command implementation and which * have to be passed to the other side of the NRE call. |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
ProcBodyFree, /* FreeInternalRep function */
ProcBodyDup, /* DupInternalRep function */
NULL, /* UpdateString function; Tcl_GetString and
* Tcl_GetStringFromObj should panic
* instead. */
NULL, /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
| < > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
ProcBodyFree, /* FreeInternalRep function */
ProcBodyDup, /* DupInternalRep function */
NULL, /* UpdateString function; Tcl_GetString and
* Tcl_GetStringFromObj should panic
* instead. */
NULL, /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
0
};
#define ProcSetInternalRep(objPtr, procPtr) \
do { \
Tcl_ObjInternalRep ir; \
(procPtr)->refCount++; \
ir.twoPtrValue.ptr1 = (procPtr); \
|
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | * The [upvar]/[uplevel] level reference type. Uses the wideValue field * to remember the integer value of a parsed #<integer> format. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. */ | | < > > > > < > | 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 |
* The [upvar]/[uplevel] level reference type. Uses the wideValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
* rep; it's just a cache type.
*/
static ObjectType levelReferenceType = {
"levelReference",
NULL,
NULL,
NULL,
NULL,
2,
NULL
};
Tcl_ObjType *levelReferenceTypePtr = (Tcl_ObjType *)&levelReferenceType;
/*
* The type of lambdas. Note that every lambda will *always* have a string
* representation.
*
* Internally, ptr1 is a pointer to a Proc instance that is not bound to a
* command name, and ptr2 is a pointer to the namespace that the Proc instance
* will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
*/
static const Tcl_ObjType lambdaType = {
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny, /* setFromAnyProc */
0
};
#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (procPtr); \
ir.twoPtrValue.ptr2 = (nsObjPtr); \
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
* A standard Tcl object result value.
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
| > > > > > > > > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
* A standard Tcl object result value.
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
void TclProcInit(void) {
Tcl_ObjInterface *oiPtr;
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListLength(oiPtr ,TclLengthOne);
Tcl_ObjTypeSetInterface(levelReferenceTypePtr ,oiPtr);
return;
}
#undef TclObjInterpProc
int
Tcl_ProcObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 | procArgs++; } /* * The argument list is just "args"; check the body */ | | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
procArgs++;
}
/*
* The argument list is just "args"; check the body
*/
procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
/*
* The body is just spaces: link the compileProc
*/
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 |
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
| | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = Tcl_GetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
* TIP #280.
* Ensure that the continuation line data for the original body is
* not lost and applies to the new body as well.
*/
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } | | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", (void *)NULL); goto procError; } argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength); /* * Check that the formal parameter name is a scalar. */ argnamei = argname; argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname; |
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
/*
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
Tcl_Size tmpLength, valueLength;
| | | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 |
/*
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
Tcl_Size tmpLength, valueLength;
const char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength);
const char *value = Tcl_GetStringFromObj(fieldValues[1], &valueLength);
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0) {
Tcl_Obj *errorObj = Tcl_ObjPrintf(
"procedure \"%s\": formal parameter \"", procName);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" has "
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 |
TclGetWideIntFromObj(NULL, objPtr, &w);
if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
result = -1;
} else {
level = curLevel - level;
result = 1;
}
| | | | 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 |
TclGetWideIntFromObj(NULL, objPtr, &w);
if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
result = -1;
} else {
level = curLevel - level;
result = 1;
}
} else if ((irPtr = TclFetchInternalRep(objPtr, levelReferenceTypePtr))) {
level = irPtr->wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
if (name[0] == '#') {
if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
if (level < 0 || (level > 0 && name[1] == '-')) {
result = -1;
} else {
Tcl_ObjInternalRep ir;
ir.wideValue = level;
Tcl_StoreInternalRep(objPtr, levelReferenceTypePtr, &ir);
result = 1;
}
} else {
result = -1;
}
} else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
/*
|
| ︙ | ︙ | |||
902 903 904 905 906 907 908 |
int
TclNRUplevelObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| < | | | | | | 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 |
int
TclNRUplevelObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
Tcl_Obj *objPtr;
if (objc < 2) {
/* to do:
* simplify things by interpreting the argument as a command when there
* is only one argument. This requires a TIP since currently a single
* argument is interpreted as a level indicator if possible.
*/
uplevelSyntax:
Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
return TCL_ERROR;
} else if (!TclHasStringRep(objv[1]) && objc == 2) {
int status;
Tcl_Size llength;
status = TclListObjLength(interp, objv[1], &llength);
|
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 |
l++;
}
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
| | > | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 |
l++;
}
TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
a[8], a[9]);
}
if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
const char *a[6];
Tcl_Size i[2];
TclDTraceInfo(info, a, i);
TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
TclDecrRefCount(info);
}
if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
|
| ︙ | ︙ | |||
2077 2078 2079 2080 2081 2082 2083 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
| | | 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > (Tcl_Size)limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ | |||
2771 2772 2773 2774 2775 2776 2777 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
| | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 |
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > (Tcl_Size)limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
(overflow ? limit : (int)nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2017 Frederic Bonnet. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclProcess.c -- * * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. */ #include "tclInt.h" /* * Autopurge flag. Process-global because of the way Tcl manages child * processes (see tclPipe.c). */ |
| ︙ | ︙ | |||
36 37 38 39 40 41 42 | } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(infoTablesMutex) | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, Tcl_Size resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular expression * mechanism. */ #include "tclInt.h" #include "tclRegexp.h" #include "tclTomMath.h" #include <assert.h> /* *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
const Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny, /* setFromAnyProc */
| < > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
const Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny, /* setFromAnyProc */
0
};
#define RegexpSetInternalRep(objPtr, rePtr) \
do { \
Tcl_ObjInternalRep ir; \
(rePtr)->refCount++; \
ir.twoPtrValue.ptr1 = (rePtr); \
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 |
Tcl_Size length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetInternalRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
| | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
Tcl_Size length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetInternalRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = Tcl_GetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
RegexpSetInternalRep(objPtr, regexpPtr);
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclRegexp.h -- * * This file contains definitions used internally by Henry Spencer's * regular expression code. */ #ifndef _TCLREGEXP #define _TCLREGEXP #include "regex.h" /* * The TclRegexp structure encapsulates a compiled regex_t, the flags that |
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclResolve.c -- * * Contains hooks for customized command/variable name resolution * schemes. These hooks allow extensions like [incr Tcl] to add their own * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1998 Lucent Technologies, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclResolve.c -- * * Contains hooks for customized command/variable name resolution * schemes. These hooks allow extensions like [incr Tcl] to add their own * name resolution rules to the Tcl language. Rules can be applied to a * particular namespace, to the interpreter as a whole, or both. */ #include "tclInt.h" /* * Declarations for functions local to this file: */ |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclResult.c -- * * This file contains code to manage the interpreter result. */ #include "tclInt.h" #include <assert.h> /* * Indices of the standard return options dictionary keys. */ |
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
Tcl_Size length;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
| | | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
Tcl_Size length;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length);
if (TclNeedSpace(bytes, bytes + length)) {
Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
}
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 | } /* *---------------------------------------------------------------------- * * Tcl_GetErrorLine -- * | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* 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,
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
| | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
(void)Tcl_GetStringFromObj(valuePtr, &length);
if (length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclScan.c -- * * This file contains the implementation of the "scan" command. */ #include "tclInt.h" #include "tclTomMath.h" #include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. */ |
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
| | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
= TclFetchInternalRep(objPtr, tclDoubleTypePtr);
if (irPtr) {
dvalue = irPtr->doubleValue;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclStrIdxTree.c -- * * Contains the routines for managing string index tries in Tcl. * * This code is back-ported from the tclSE engine, by Serg G. Brester. * * Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ----------------------------------------------------------------------- * * String index tries are prepaired structures used for fast greedy search of the string * (index) by unique string prefix as key. * * Index tree build for two lists together can be explained in the following datagram | > > > > > > > > > > > > > > | 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 | /* * tclStrIdxTree.c -- * * Contains the routines for managing string index tries in Tcl. * * This code is back-ported from the tclSE engine, by Serg G. Brester. * * Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * * * ----------------------------------------------------------------------- * * String index tries are prepaired structures used for fast greedy search of the string * (index) by unique string prefix as key. * * Index tree build for two lists together can be explained in the following datagram |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
static const Tcl_ObjType StrIdxTreeObjType = {
"str-idx-tree", /* name */
StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */
StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */
StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
NULL, /* setFromAnyProc */
| < > | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
static const Tcl_ObjType StrIdxTreeObjType = {
"str-idx-tree", /* name */
StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */
StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */
StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
*----------------------------------------------------------------------
*
* TclStrIdxTreeSearch --
*
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | /* * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions * to/from floating-point in Tcl. They include TclParseNumber, which * parses numbers from strings; TclDoubleDigits, which formats numbers * into strings of digits, and procedures for interconversion among * 'double' and 'mp_int' types. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2005 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStrToD.c -- * * This file contains a collection of procedures for managing conversions * to/from floating-point in Tcl. They include TclParseNumber, which * parses numbers from strings; TclDoubleDigits, which formats numbers * into strings of digits, and procedures for interconversion among * 'double' and 'mp_int' types. */ #include "tclInt.h" #include "tclTomMath.h" #include <float.h> #include <math.h> |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | /* * Sun ProC needs sunmath for rounding control on x86 like gcc above. */ # elif defined(__sun) # include <sunmath.h> # define TCL_IEEE_DOUBLE_ROUNDING_DECL # define TCL_IEEE_DOUBLE_ROUNDING \ | | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
/*
* Sun ProC needs sunmath for rounding control on x86 like gcc above.
*/
# elif defined(__sun)
# include <sunmath.h>
# define TCL_IEEE_DOUBLE_ROUNDING_DECL
# define TCL_IEEE_DOUBLE_ROUNDING \
ieee_flags("set", "precision", "double", NULL)
# define TCL_DEFAULT_DOUBLE_ROUNDING \
ieee_flags("clear", "precision", NULL, NULL)
# endif
#endif
/*
* Other platforms are assumed to always operate in full IEEE mode, so we make
* the macros to go in and out of that mode do nothing.
*/
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
*/
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
| | | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
*/
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
if (TclHasInternalRep(objPtr, tclDictTypePtr)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, tclListTypePtr)) {
Tcl_Size length;
/* A list can only be a (single) number if its length == 1 */
TclListObjLength(NULL, objPtr, &length);
if (length != 1) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
1380 1381 1382 1383 1384 1385 1386 |
}
if (!octalSignificandOverflow) {
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
| | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
}
if (!octalSignificandOverflow) {
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = tclIntTypePtr;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-octalSignificandWide);
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt)octalSignificandWide;
}
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 |
returnInteger:
if (!significandOverflow) {
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
| | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
returnInteger:
if (!significandOverflow) {
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = tclIntTypePtr;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-significandWide);
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt)significandWide;
}
|
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 | * Here, we're parsing a floating-point number. 'significandWide' * or 'significandBig' contains the exact significand, according * to whether 'significandOverflow' is set. The desired floating * point value is significand * 10**k, where * k = numTrailZeros+exponent-numDigitsAfterDp. */ | | | 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 |
* Here, we're parsing a floating-point number. 'significandWide'
* or 'significandBig' contains the exact significand, according
* to whether 'significandOverflow' is set. The desired floating
* point value is significand * 10**k, where
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
objPtr->typePtr = tclDoubleTypePtr;
if (exponentSignum) {
/*
* At this point exponent>=0, so the following calculation
* cannot underflow.
*/
exponent = -exponent;
}
|
| ︙ | ︙ | |||
1499 1500 1501 1502 1503 1504 1505 |
case sINF:
case sINFINITY:
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
| | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
case sINF:
case sINFINITY:
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
objPtr->typePtr = tclDoubleTypePtr;
break;
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
objPtr->typePtr = tclDoubleTypePtr;
break;
#endif
case INITIAL:
/* This case only to silence compiler warning. */
Tcl_Panic("TclParseNumber: state INITIAL can't happen here");
}
}
|
| ︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 |
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) {
| | > | > | > | > | > | > | 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 |
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) {
w >>= 32;
rv += 32;
}
if (!(w & (Tcl_WideUInt) 0xFFFF)) {
w >>= 16;
rv += 16;
}
if (!(w & (Tcl_WideUInt) 0xFF)) {
w >>= 8;
rv += 8;
}
if (!(w & (Tcl_WideUInt) 0xF)) {
w >>= 4;
rv += 4;
}
if (!(w & 0x3)) {
w >>= 2;
rv += 2;
}
if (!(w & 0x1)) {
w >>= 1;
++rv;
}
*wPtr = w;
return rv;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2301 2302 2303 2304 2305 2306 2307 |
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) {
| | > | > | > | > | > | > | > | 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 |
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) {
wi = (unsigned long) (w >> 32);
rv = 32;
} else {
wi = (unsigned long) w;
rv = 0;
}
if (wi & 0xFFFF0000) {
wi >>= 16;
rv += 16;
}
if (wi & 0xFF00) {
wi >>= 8;
rv += 8;
}
if (wi & 0xF0) {
wi >>= 4;
rv += 4;
}
if (wi & 0xC) {
wi >>= 2;
rv += 2;
}
if (wi & 0x2) {
wi >>= 1;
++rv;
}
if (wi & 0x1) {
++rv;
}
return rv;
}
|
| ︙ | ︙ | |||
3144 3145 3146 3147 3148 3149 3150 |
/*
* Adjust if the logarithm was guessed wrong.
*/
if (b < S) {
b = 10 * b;
| | > > | 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 |
/*
* Adjust if the logarithm was guessed wrong.
*/
if (b < S) {
b = 10 * b;
++m2plus;
++m2minus;
++m5;
ilim = ilim1;
--k;
}
/*
* Compute roundoff ranges.
*/
|
| ︙ | ︙ | |||
3523 3524 3525 3526 3527 3528 3529 |
/*
* Adjust if the logarithm was guessed wrong.
*/
if ((err == MP_OKAY) && (b.used <= sd)) {
err = mp_mul_d(&b, 10, &b);
| | > > | 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 |
/*
* Adjust if the logarithm was guessed wrong.
*/
if ((err == MP_OKAY) && (b.used <= sd)) {
err = mp_mul_d(&b, 10, &b);
++m2plus;
++m2minus;
++m5;
ilim = ilim1;
--k;
}
/*
* mminus = 5**m5 * 2**m2minus
* mplus = 5**m5 * 2**m2plus
|
| ︙ | ︙ | |||
3563 3564 3565 3566 3567 3568 3569 |
if (b.used <= sd) {
digit = 0;
} else {
digit = b.dp[sd];
if (b.used > sd+1 || digit >= 10) {
Tcl_Panic("wrong digit!");
}
| | > | 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 |
if (b.used <= sd) {
digit = 0;
} else {
digit = b.dp[sd];
if (b.used > sd+1 || digit >= 10) {
Tcl_Panic("wrong digit!");
}
--b.used;
mp_clamp(&b);
}
/*
* Does the current digit put us on the low side of the exact value
* but within within roundoff of being exact?
*/
|
| ︙ | ︙ | |||
4539 4540 4541 4542 4543 4544 4545 |
int len = i;
/*
* Reduce numerator and denominator to lowest terms.
*/
if (b2 >= s2 && s2 > 0) {
| | > | > | 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 |
int len = i;
/*
* Reduce numerator and denominator to lowest terms.
*/
if (b2 >= s2 && s2 > 0) {
b2 -= s2;
s2 = 0;
} else if (s2 >= b2 && b2 > 0) {
s2 -= b2;
b2 = 0;
}
if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) {
/*
* If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
* then all our intermediate calculations can be done using exact
* 64-bit arithmetic with no need for expensive multiprecision
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclStringObj.c -- * * This file contains functions that implement string operations on Tcl * objects. Some string operations work with UTF-8 encoding forms. * Functions that require knowledge of the width of each character, | > > > > > > > > > > > > > > > > > | | | | < < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStringObj.c -- * * This file contains functions that implement string operations on Tcl * objects. Some string operations work with UTF-8 encoding forms. * Functions that require knowledge of the width of each character, * such as indexing, operate on fixed width encoding forms such as UTF-32. * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of * UTF-8 or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of * numChars, but we don't store the fixed form encoding (unless * Tcl_GetUnicode is explicitly called). * * The String object type stores one or both formats. The default * behavior is to store UTF-8. Once UTF-16/UTF32 is calculated, it is * stored in the internal rep for future access (without an additional * O(n) cost). * * To allow many appends to be done to an object without constantly * reallocating space, we allocate double the space and use the * internal representation to keep track of how much space is used vs. * allocated. */ #include "tclInt.h" #include "tclTomMath.h" #include "tclStringRep.h" #include <assert.h> /* |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | static Tcl_Size ExtendStringRepWithUnicode(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, const char *bytes, Tcl_Size numBytes, Tcl_Size numAppendChars); static void FillUnicodeRep(Tcl_Obj *objPtr); static void FreeStringInternalRep(Tcl_Obj *objPtr); static void GrowStringBuffer(Tcl_Obj *objPtr, Tcl_Size needed, int flag); static void GrowUnicodeBuffer(Tcl_Obj *objPtr, Tcl_Size needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); | > > < < < < > | 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 |
static Tcl_Size ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, Tcl_Size numChars);
static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
const char *bytes, Tcl_Size numBytes,
Tcl_Size numAppendChars);
static void FillUnicodeRep(Tcl_Obj *objPtr);
static void FreeStringInternalRep(Tcl_Obj *objPtr);
static int GetCharLength(Tcl_Obj *objPtr, Tcl_Size *length);
static int GetRange(tclObjTypeInterfaceArgsStringRange);
static void GrowStringBuffer(Tcl_Obj *objPtr, Tcl_Size needed, int flag);
static void GrowUnicodeBuffer(Tcl_Obj *objPtr, Tcl_Size needed);
static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, Tcl_Size numChars);
static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode);
static void UpdateStringOfString(Tcl_Obj *objPtr);
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
*/
const Tcl_ObjType tclStringType = {
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
UpdateStringOfString, /* updateStringProc */
SetStringFromAny, /* setFromAnyProc */
0
};
/*
* TCL STRING GROWTH ALGORITHM
*
* When growing strings (during an append, for example), the following growth
* algorithm is used:
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 | * * Side effects: * Frees old internal rep. Allocates memory for new "String" internal * rep. * *---------------------------------------------------------------------- */ | < > > > > > > > > > > > > > > > > > > > | > | > | > | 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 |
*
* Side effects:
* Frees old internal rep. Allocates memory for new "String" internal
* rep.
*
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_GetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
int status;
Tcl_Size length;
status = TclObjectDispatch(objPtr, GetCharLength,
string, length, objPtr ,&length);
if (status) {
/* to do
* have Tcl_GetCharLength return a standard result
*/
Tcl_Panic("%s failed", "Tcl_GetCharLength");
}
return length;
}
int
GetCharLength(
Tcl_Obj *objPtr
,Tcl_Size *length
)
{
String *stringPtr;
Tcl_Size numChars = 0;
/*
* Quick, no-shimmer return for short string reps.
*/
if ((objPtr->bytes) && (objPtr->length < 2)) {
/* 0 bytes -> 0 chars; 1 byte -> 1 char */
*length = objPtr->length;
return TCL_OK;
}
/*
* Optimize the case where we're really dealing with a bytearray object;
* we don't need to convert to a string to perform the get-length operation.
*
* Starting in Tcl 8.7, we check for a "pure" bytearray, because the
* machinery behind that test is using a proper bytearray ObjType. We
* could also compute length of an improper bytearray without shimmering
* but there's no value in that. We *want* to shimmer an improper bytearray
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
(void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars);
*length = numChars;
return TCL_OK;
}
/*
* OK, need to work with the object as a string.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
numChars = stringPtr->numChars;
/*
* If numChars is unknown, compute it.
*/
if (numChars < 0) {
TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
}
*length = numChars;
return TCL_OK;
}
Tcl_Size
TclGetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
|
| ︙ | ︙ | |||
473 474 475 476 477 478 479 | * Side effects: * None. * *---------------------------------------------------------------------- */ int TclCheckEmptyString( | > | > > > | > | > | | > > > | > > | > > > | > > > > > > > | > | > | > | 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 |
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCheckEmptyString(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int *res
)
{
int status;
Tcl_Size length = 0;
if (objPtr->bytes == &tclEmptyString) {
*res = TCL_EMPTYSTRING_YES;
return TCL_OK;
}
if (TclIsPureByteArray(objPtr)
&& Tcl_GetCharLength(objPtr) == 0) {
*res = TCL_EMPTYSTRING_YES;
return TCL_OK;
}
if (TclListObjIsCanonical(objPtr)) {
status = TclListObjLength(interp, objPtr, &length);
if (status) {
return status;
} else {
*res = length == 0;
return TCL_OK;
}
}
if (TclIsPureDict(objPtr)) {
status = Tcl_DictObjSize(interp, objPtr, &length);
if (status) {
return status;
} else {
*res = length == 0;
return TCL_OK;
}
}
if (objPtr->bytes == NULL) {
if (TclObjectHasInterface(objPtr, string, isEmpty)) {
TclObjectDispatchNoDefault(interp ,status ,objPtr ,string
,isEmpty ,interp ,objPtr ,res);
return status;
} else {
*res = TCL_EMPTYSTRING_UNKNOWN;
return TCL_OK;
}
}
*res = objPtr->length == 0;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUniChar --
*
|
| ︙ | ︙ | |||
637 638 639 640 641 642 643 | * Side effects: * Converts the object to have the String internal rep. * *---------------------------------------------------------------------- */ #undef Tcl_GetUnicodeFromObj | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetUnicodeFromObj
Tcl_UniChar *
Tcl_GetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the unicode string
* for. */
Tcl_Size *lengthPtr) /* If non-NULL, the location where the string
* rep's unichar length should be stored. If
* NULL, no length is stored. */
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
Tcl_Size first, /* First index of the range. */
Tcl_Size last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
Tcl_Size length = 0;
if (first < 0) {
first = 0;
}
| > > > > > > > > > | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
Tcl_Size first, /* First index of the range. */
Tcl_Size last) /* Last index of the range. */
{
Tcl_Obj *resPtr;
TclObjectDispatch(objPtr, GetRange,
string, range, objPtr, first, last, &resPtr);
return resPtr;
}
int
GetRange(tclObjTypeInterfaceArgsStringRange) {
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
Tcl_Size length = 0;
if (first < 0) {
first = 0;
}
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length);
if (last < 0 || last >= length) {
last = length - 1;
}
if (last < first) {
TclNewObj(newObjPtr);
| | > | > > | | > | > | > | > > | > > | 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 |
unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length);
if (last < 0 || last >= length) {
last = length - 1;
}
if (last < first) {
TclNewObj(newObjPtr);
*resPtrPtr = newObjPtr;
return TCL_OK;
}
*resPtrPtr = Tcl_NewByteArrayObj(bytes + first, last - first + 1);
return TCL_OK;
}
/*
* OK, need to work with the object as a string.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == TCL_INDEX_NONE) {
TclNumUtfCharsM(
stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
if (last < 0 || last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
if (last < first) {
TclNewObj(newObjPtr);
*resPtrPtr = newObjPtr;
return TCL_OK;
}
newObjPtr = Tcl_NewStringObj(
objPtr->bytes + first, last - first + 1);
/*
* Since we know the char length of the result, store it.
*/
SetStringFromAny(NULL, newObjPtr);
stringPtr = GET_STRING(newObjPtr);
stringPtr->numChars = newObjPtr->length;
*resPtrPtr = newObjPtr;
return TCL_OK;
}
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (last < 0 || last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
if (last < first) {
TclNewObj(newObjPtr);
*resPtrPtr = newObjPtr;
return TCL_OK;
}
*resPtrPtr = Tcl_NewUnicodeObj(
stringPtr->unicode + first, last - first + 1);
return TCL_OK;
}
Tcl_Obj *
TclGetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
Tcl_Size first, /* First index of the range. */
Tcl_Size last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
| < < < < < < | 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 |
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && (stringPtr->numChars > 0)) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
}
if (length <= limit) {
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 1382 |
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
Tcl_Size length = 0, numChars;
Tcl_Size appendNumChars = TCL_INDEX_NONE;
const char *bytes;
| > > > > > > > | > > > > | | 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 |
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
Tcl_Size length = 0, numChars;
Tcl_Size appendNumChars = TCL_INDEX_NONE;
const char *bytes;
int isEmpty, status;
status = TclCheckEmptyString(NULL, appendObjPtr, &isEmpty);
/* No way to return an error. Panic. */
if (status) {
Tcl_Panic("%s: TclCheckEmptyString failed, %s", "Tcl_AppendObjToObj", "appendObjPtr");
}
if (isEmpty == TCL_EMPTYSTRING_YES) {
return;
}
status = TclCheckEmptyString(NULL, objPtr, &isEmpty);
if (status) {
Tcl_Panic("%s: TclCheckEmptyString failed, %s", "Tcl_AppendObjToObj", "objPtr");
}
if (isEmpty == TCL_EMPTYSTRING_YES) {
TclSetDuplicateObj(objPtr, appendObjPtr);
return;
}
if (TclIsPureByteArray(appendObjPtr)
&& (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) {
/*
|
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 |
/*
* Must append as strings.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
| < < < < < < < | | | 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 |
/*
* Must append as strings.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
*/
if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (TclHasInternalRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
* Append to objPtr's UTF string rep. If we know the number of characters
* in both objects before appending, then set the combined number of
* characters in the final (appended-to) object.
*/
bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 |
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
| | | 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 |
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
(void)Tcl_GetStringFromObj(appendObj, &originalLength);
limit = TCL_SIZE_MAX - originalLength;
/*
* Format string is NUL-terminated.
*/
while (*format != '\0') {
|
| ︙ | ︙ | |||
2284 2285 2286 2287 2288 2289 2290 |
TclNewIntObj(pure, w);
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
| | | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 |
TclNewIntObj(pure, w);
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
bytes = Tcl_GetStringFromObj(pure, &length);
/*
* Already did the sign above.
*/
if (*bytes == '-') {
length--;
|
| ︙ | ︙ | |||
2526 2527 2528 2529 2530 2531 2532 |
*p++ = (char) ch;
*p = '\0';
TclNewObj(segment);
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
| < | < < | < | | | | 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 |
*p++ = (char) ch;
*p = '\0';
TclNewObj(segment);
allocSegment = 1;
if (!Tcl_AttemptSetObjLength(segment, length)) {
Tcl_DecrRefCount(segment);
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
bytes = TclGetString(segment);
if (!Tcl_AttemptSetObjLength(segment, snprintf(bytes, segment->length, spec, d))) {
Tcl_DecrRefCount(segment);
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
if (ch == 'A') {
char *q = TclGetString(segment) + 1;
*q = 'x';
q = strchr(q, 'P');
if (q) {
*q = 'p';
}
}
break;
}
default:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%c\"", ch));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (char *)NULL);
}
goto error;
}
if (width>0 && numChars<0) {
numChars = Tcl_GetCharLength(segment);
}
if (!gotMinus && width>0) {
if (numChars < width) {
limit -= width - numChars;
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
(void)Tcl_GetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 |
q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
}
Tcl_ListObjAppendElement(NULL, list,
| | | 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 |
q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
}
Tcl_ListObjAppendElement(NULL, list,
Tcl_NewStringObj(bytes, (end - bytes)));
break;
}
case 'p':
if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
size = 2;
}
|
| ︙ | ︙ | |||
2802 2803 2804 2805 2806 2807 2808 |
case 'A':
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
if (size > 0) {
| | | | | | 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 |
case 'A':
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
if (size > 0) {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
(double) va_arg(argList, long double)));
} else {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
va_arg(argList, double)));
}
seekingConversion = 0;
break;
case '*':
lastNum = va_arg(argList, int);
Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
|
| ︙ | ︙ | |||
2957 2958 2959 2960 2961 2962 2963 |
TclGetStringStorage(
Tcl_Obj *objPtr,
Tcl_Size *sizePtr)
{
String *stringPtr;
if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
| | | 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 |
TclGetStringStorage(
Tcl_Obj *objPtr,
Tcl_Size *sizePtr)
{
String *stringPtr;
if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
return Tcl_GetStringFromObj(objPtr, sizePtr);
}
stringPtr = GET_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
|
| ︙ | ︙ | |||
3023 3024 3025 3026 3027 3028 3029 |
maxCount = TCL_SIZE_MAX;
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
(void)Tcl_GetUnicodeFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar);
} else {
/* Result will be concat of string reps. Pre-size it. */
| | | 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 |
maxCount = TCL_SIZE_MAX;
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
(void)Tcl_GetUnicodeFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar);
} else {
/* Result will be concat of string reps. Pre-size it. */
(void)Tcl_GetStringFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX;
}
if (length == 0) {
/* Any repeats of empty is empty. */
return objPtr;
}
|
| ︙ | ︙ | |||
3147 3148 3149 3150 3151 3152 3153 |
Tcl_Size objc,
Tcl_Obj * const objv[],
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
int binary = 1;
Tcl_Size oc, length = 0;
| | | 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 |
Tcl_Size objc,
Tcl_Obj * const objv[],
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
int binary = 1;
Tcl_Size oc, length = 0;
int allowUniChar = 1, requestUniChar = 0;
Tcl_Size first = objc - 1; /* Index of first value possibly not empty */
Tcl_Size last = 0; /* Index of last value possibly not empty */
int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv);
if (objc <= 1) {
if (objc != 1) {
/* Negative (shouldn't be) no objects; return empty */
|
| ︙ | ︙ | |||
3179 3180 3181 3182 3183 3184 3185 |
Tcl_Obj *objPtr = *ov++;
if (TclIsPureByteArray(objPtr)) {
allowUniChar = 0;
} else if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
| | | | | | | < | | | | | 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 |
Tcl_Obj *objPtr = *ov++;
if (TclIsPureByteArray(objPtr)) {
allowUniChar = 0;
} else if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
/*
* Non-empty string rep. Not a pure bytearray, so we won't
* create a pure bytearray.
*/
binary = 0;
if ((objPtr->typePtr)
&& !TclHasInternalRep(objPtr, &tclStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
}
} else {
binary = 0;
if (TclHasInternalRep(objPtr, &tclStringType)) {
/* Have a pure Unicode value; ask to preserve it */
requestUniChar = 1;
} else {
|
| ︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 |
if (length > (TCL_SIZE_MAX-numBytes)) {
goto overflow;
}
length += numBytes;
}
}
} while (--oc);
| | | 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 |
if (length > (TCL_SIZE_MAX-numBytes)) {
goto overflow;
}
length += numBytes;
}
}
} while (--oc);
} else if ((allowUniChar && requestUniChar)) {
/*
* Result will be pure Tcl_UniChar array. Pre-size it.
*/
ov = objv;
oc = objc;
do {
|
| ︙ | ︙ | |||
3264 3265 3266 3267 3268 3269 3270 |
}
length += numChars;
}
}
} while (--oc);
} else {
/* Result will be concat of string reps. Pre-size it. */
| | > > > > > > | < | | 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 |
}
length += numChars;
}
}
} while (--oc);
} else {
/* Result will be concat of string reps. Pre-size it. */
ov = objv;
oc = objc;
do {
Tcl_Obj *pendingPtr = NULL;
/*
* Loop until a possibly non-empty value is reached.
* Keep string rep generation pending when possible.
*/
do {
int isEmpty, status;
Tcl_Obj *objPtr = *ov++;
status = TclCheckEmptyString(NULL, objPtr, &isEmpty);
if (status) {
return NULL;
}
if (objPtr->bytes == NULL && isEmpty != TCL_EMPTYSTRING_YES) {
/* No string rep; Take the chance we can avoid making it */
pendingPtr = objPtr;
} else {
(void) Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
}
} while (--oc && (length == 0) && (pendingPtr == NULL));
/*
* Either we found a possibly non-empty value, and we remember
* this index as the first and last such value so far seen,
* or (oc == 0) and all values are known empty,
|
| ︙ | ︙ | |||
3305 3306 3307 3308 3309 3310 3311 |
* There's a pending value followed by more values. Loop over
* remaining values generating strings until a non-empty value
* is found, or the pending value gets its string generated.
*/
do {
Tcl_Obj *objPtr = *ov++;
| | | | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 |
* There's a pending value followed by more values. Loop over
* remaining values generating strings until a non-empty value
* is found, or the pending value gets its string generated.
*/
do {
Tcl_Obj *objPtr = *ov++;
(void)Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
} while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
if (numBytes) {
last = objc -oc -1;
}
if (oc || numBytes) {
(void)Tcl_GetStringFromObj(pendingPtr, &length);
}
if (length == 0) {
if (numBytes) {
first = last;
}
} else if (numBytes > (TCL_SIZE_MAX - length)) {
goto overflow;
|
| ︙ | ︙ | |||
3348 3349 3350 3351 3352 3353 3354 |
if (last <= first /*|| length == 0 */) {
/* Only one non-empty value or zero length; return first */
/* NOTE: (length == 0) implies (last <= first) */
return objv[first];
}
| > | | > | 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 |
if (last <= first /*|| length == 0 */) {
/* Only one non-empty value or zero length; return first */
/* NOTE: (length == 0) implies (last <= first) */
return objv[first];
}
objv += first;
objc = (last - first + 1);
inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv);
if (binary) {
/* Efficiently produce a pure byte array result */
unsigned char *dst;
/*
* Broken interface! Byte array value routines offer no way to handle
* failure to allocate enough space. Following stanza may panic.
*/
if (inPlace) {
Tcl_Size start = 0;
objResultPtr = *objv++;
objc--;
(void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start);
dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
} else {
objResultPtr = Tcl_NewByteArrayObj(NULL, length);
dst = Tcl_SetByteArrayLength(objResultPtr, length);
}
while (objc--) {
|
| ︙ | ︙ | |||
3386 3387 3388 3389 3390 3391 3392 |
if (TclIsPureByteArray(objPtr)) {
Tcl_Size more = 0;
unsigned char *src = Tcl_GetBytesFromObj(NULL, objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
| | | > | 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 |
if (TclIsPureByteArray(objPtr)) {
Tcl_Size more = 0;
unsigned char *src = Tcl_GetBytesFromObj(NULL, objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
} else if ((allowUniChar && requestUniChar)) {
/* Efficiently produce a pure Tcl_UniChar array result */
Tcl_UniChar *dst;
if (inPlace) {
Tcl_Size start;
objResultPtr = *objv++;
objc--;
/* Ugly interface! Force resize of the unicode array. */
(void)Tcl_GetUnicodeFromObj(objResultPtr, &start);
Tcl_InvalidateStringRep(objResultPtr);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
3444 3445 3446 3447 3448 3449 3450 |
} else {
/* Efficiently concatenate string reps */
char *dst;
if (inPlace) {
Tcl_Size start;
| | > | | 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 |
} else {
/* Efficiently concatenate string reps */
char *dst;
if (inPlace) {
Tcl_Size start;
objResultPtr = *objv++;
objc--;
(void)Tcl_GetStringFromObj(objResultPtr, &start);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %" TCL_SIZE_MODIFIER "d bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL);
}
|
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 |
dst = TclGetString(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
Tcl_Size more;
| | | 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 |
dst = TclGetString(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
Tcl_Size more;
char *src = Tcl_GetStringFromObj(objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
/* Must NUL-terminate! */
*dst = '\0';
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 |
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
int nocase, /* comparison is not case sensitive */
Tcl_Size reqlength) /* requested length in characters;
* TCL_INDEX_NONE to compare whole strings */
{
const char *s1, *s2;
| | | 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 |
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
int nocase, /* comparison is not case sensitive */
Tcl_Size reqlength) /* requested length in characters;
* TCL_INDEX_NONE to compare whole strings */
{
const char *s1, *s2;
int empty, empty2, match, status;
Tcl_Size length, s1len = 0, s2len = 0;
memCmpFn_t memCmpFn;
if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
/*
* Always match at 0 chars of if it is the same obj.
* Note: as documented reqlength negative means it is ignored
|
| ︙ | ︙ | |||
3706 3707 3708 3709 3710 3711 3712 |
}
} else {
memCmpFn = UniCharNmemcmp;
}
}
}
} else {
| | > > > > > > > > > | | | | | | | 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 |
}
} else {
memCmpFn = UniCharNmemcmp;
}
}
}
} else {
status = TclCheckEmptyString(NULL, value1Ptr, &empty);
if (status) {
/* No way to report an error */
Tcl_Panic("TclStringCmp TclCheckEmptyString value1Ptr");
}
status = TclCheckEmptyString(NULL, value2Ptr, &empty2);
if (status) {
/* No way to report an error */
Tcl_Panic("TclStringCmp TclCheckEmptyString value2Ptr");
}
if (empty > 0) {
switch (empty2) {
case -1:
s1 = "";
s1len = 0;
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
break;
case 0:
match = -1;
goto matchdone;
case 1:
default: /* avoid warn: `s2` may be used uninitialized */
match = 0;
goto matchdone;
}
} else if (empty2 > 0) {
switch (empty) {
case -1:
s2 = "";
s2len = 0;
s1 = Tcl_GetStringFromObj(value1Ptr, &s1len);
break;
case 0:
match = 1;
goto matchdone;
case 1:
default: /* avoid warn: `s1` may be used uninitialized */
match = 0;
goto matchdone;
}
} else {
s1 = Tcl_GetStringFromObj(value1Ptr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
}
if (!nocase && checkEq && reqlength < 0) {
/*
* When we have equal-length we can check only for
* (in)equality. We can use memcmp in all (n)eq cases because
* we don't need to worry about lexical LE/BE variance.
*/
|
| ︙ | ︙ | |||
3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 |
goto firstEnd;
}
}
firstEnd:
TclNewIndexObj(obj, value);
return obj;
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
goto firstEnd;
}
}
firstEnd:
TclNewIndexObj(obj, value);
return obj;
}
int
TclStringIndexInterface(
Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *indexPtr, Tcl_Obj **charPtrPtr)
{
Tcl_Size index, status;
status = TclGetIntForIndexM(interp, indexPtr, /*endValue*/ TCL_SIZE_MAX - 1,
&index);
if (status != TCL_OK) {
return status;
}
if (TclIndexIsFromEnd(index)) {
if (TclObjectInterfaceCall(objPtr, string, indexEnd,
interp, objPtr, index, charPtrPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
if (TclObjectInterfaceCall(objPtr, string, index, interp, objPtr,
index, charPtrPtr) != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | /* * tclStringRep.h -- * * This file contains the definition of internal representations of a string * and macros to access it. * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of UTF-8 * or UTF-32. | > > > > > > > > > > > > > > > > > < < < < < < | 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 | /* * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStringRep.h -- * * This file contains the definition of internal representations of a string * and macros to access it. * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of UTF-8 * or UTF-32. */ #ifndef _TCLSTRINGREP #define _TCLSTRINGREP /* * The following structure is the internal rep for a String object. It keeps |
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003-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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStringTrim.h -- * * This file contains the definition of what characters are to be trimmed * from a string by [string trim] by default. It's only needed by Tcl's * implementation; it does not form a public or private API at all. */ #ifndef TCL_STRING_TRIM_H #define TCL_STRING_TRIM_H /* * 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] */ |
| ︙ | ︙ |
1 | /* | < < > > > > > > > > > > > > > | | | 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 | /* * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStubCall.c -- */ #include "tclInt.h" #ifndef _WIN32 # include <dlfcn.h> #else # define dlopen(a, b) (void *)LoadLibraryW(JOIN(L, a)) # define dlsym(a, b) (void *)GetProcAddress((HMODULE)(a), b) # define dlerror() "" #endif MODULE_SCOPE void *tclStubsHandle; /* *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
"_Tcl_StaticLibrary", /* "arg" == (void *)6 */
"_Tcl_SetExitProc", /* "arg" == (void *)7 */
"_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */
"_Tcl_SetPreInitScript" /* "arg" == (void *)9 */
};
MODULE_SCOPE const void *nullVersionProc(void) {
| | | > | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
"_Tcl_StaticLibrary", /* "arg" == (void *)6 */
"_Tcl_SetExitProc", /* "arg" == (void *)7 */
"_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */
"_Tcl_SetPreInitScript" /* "arg" == (void *)9 */
};
MODULE_SCOPE const void *nullVersionProc(void) {
return NULL;
}
static const char CANNOTCALL[] = "Cannot call %s from stubbed extension\n";
static const char CANNOTFIND[] = "Cannot find %s: %s\n";
MODULE_SCOPE void *
TclStubCall(
void *arg)
{
static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL};
size_t index = PTR2UINT(arg);
if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) {
/* Any other value means Tcl_SetPanicProc() with non-null panicProc */
index = 0;
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. */ #include "tclInt.h" #include "tommath_private.h" #include "tclTomMath.h" #ifdef __CYGWIN__ # include <wchar.h> #endif |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 71 | #undef Tcl_ListObjGetElements #undef Tcl_ListObjLength #undef Tcl_DictObjSize #undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv #undef TclStaticLibrary #define TclStaticLibrary Tcl_StaticLibrary #undef TclObjInterpProc #if !defined(_WIN32) && !defined(__CYGWIN__) # undef Tcl_WinConvertError # define Tcl_WinConvertError 0 #endif | > > > > > > | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | #undef Tcl_ListObjGetElements #undef Tcl_ListObjLength #undef Tcl_DictObjSize #undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS #undef TclStaticLibrary #undef Tcl_BackgroundError #define TclStaticLibrary Tcl_StaticLibrary #undef TclObjInterpProc #if !defined(_WIN32) && !defined(__CYGWIN__) # undef Tcl_WinConvertError # define Tcl_WinConvertError 0 #endif # undef TclGetBytesFromObj # undef TclGetUnicodeFromObj # define TclGetBytesFromObj 0 # define TclGetUnicodeFromObj 0 #undef Tcl_Close #define Tcl_Close 0 #undef Tcl_GetByteArrayFromObj #define Tcl_GetByteArrayFromObj 0 #define TclUnusedStubEntry 0 #define TclUtfCharComplete Tcl_UtfCharComplete #define TclUtfNext Tcl_UtfNext #define TclUtfPrev Tcl_UtfPrev #undef TclListObjGetElements #undef TclListObjLength # define TclListObjGetElements 0 # define TclListObjLength 0 # define TclDictObjSize 0 # define TclSplitList 0 # define TclSplitPath 0 # define TclFSSplitPath 0 # define TclParseArgsObjv 0 # define TclGetAliasObj 0 #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp #define TclBN_mp_clear mp_clear #define TclBN_mp_clear_multi mp_clear_multi |
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
/* dummy implementation, no need to do anything */
}
# define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing
# define TclWinFlushDirtyChannels doNothing
#define TclWinNoBackslash winNoBackslash
static char *
| | > > | | > > | > > | > > > > | > > | > > > | 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 |
/* dummy implementation, no need to do anything */
}
# define TclWinAddProcess (void (*) (void *, Tcl_Size)) doNothing
# define TclWinFlushDirtyChannels doNothing
#define TclWinNoBackslash winNoBackslash
static char *
TclWinNoBackslash(
char *path)
{
char *p;
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
void *
TclWinGetTclInstance(void)
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
Tcl_Size
TclpGetPid(
Tcl_Pid pid)
{
return (Tcl_Size)PTR2INT(pid);
}
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the Win64
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
#define Tcl_GetLongFromObj \
(int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)Tcl_GetIntFromObj
static int
exprInt(
Tcl_Interp *interp,
const char *expr,
int *ptr)
{
long longValue;
int result = Tcl_ExprLong(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLong \
(int(*)(Tcl_Interp*,const char*,long*))(void *)exprInt
static int
exprIntObj(
Tcl_Interp *interp,
Tcl_Obj*expr,
int *ptr)
{
long longValue;
int result = Tcl_ExprLongObj(interp, expr, &longValue);
if (result == TCL_OK) {
if ((longValue >= (long)(INT_MIN))
&& (longValue <= (long)(UINT_MAX))) {
*ptr = (int)longValue;
} else {
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | */ #pragma GCC diagnostic ignored "-Wdeprecated-declarations" #endif #ifdef TCL_WITH_EXTERNAL_TOMMATH /* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't * exist (since that was introduced in libtommath 1.3.0. Provide it here.) */ | | > > > > > | | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
*/
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
#ifdef TCL_WITH_EXTERNAL_TOMMATH
/* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't
* exist (since that was introduced in libtommath 1.3.0. Provide it here.) */
mp_err MP_WUR
TclBN_mp_expt_n(
const mp_int *a,
int b,
mp_int *c)
{
if ((unsigned)b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
return MP_VAL;
}
return mp_expt_u32(a, (uint32_t)b, c);;
}
#endif /* TCL_WITH_EXTERNAL_TOMMATH */
/* !BEGIN!: Do not edit below this line. */
static const TclIntStubs tclIntStubs = {
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 |
Tcl_GetDouble, /* 34 */
Tcl_GetDoubleFromObj, /* 35 */
0, /* 36 */
Tcl_GetInt, /* 37 */
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
| | | | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
Tcl_GetDouble, /* 34 */
Tcl_GetDoubleFromObj, /* 35 */
0, /* 36 */
Tcl_GetInt, /* 37 */
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
0, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
0, /* 45 */
Tcl_ListObjIndex, /* 46 */
0, /* 47 */
Tcl_ListObjReplace, /* 48 */
0, /* 49 */
Tcl_NewByteArrayObj, /* 50 */
Tcl_NewDoubleObj, /* 51 */
0, /* 52 */
Tcl_NewListObj, /* 53 */
0, /* 54 */
|
| ︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
Tcl_UtfNcmp, /* 686 */
Tcl_UtfNcasecmp, /* 687 */
Tcl_NewWideUIntObj, /* 688 */
Tcl_SetWideUIntObj, /* 689 */
TclUnusedStubEntry, /* 690 */
};
/* !END!: Do not edit above this line. */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_GetWideUIntFromObj, /* 684 */
Tcl_DStringToObj, /* 685 */
Tcl_UtfNcmp, /* 686 */
Tcl_UtfNcasecmp, /* 687 */
Tcl_NewWideUIntObj, /* 688 */
Tcl_SetWideUIntObj, /* 689 */
TclUnusedStubEntry, /* 690 */
Tcl_NewObjInterface, /* 691 */
Tcl_NewObjType, /* 692 */
Tcl_ObjInterfaceSetVersion, /* 693 */
Tcl_ObjTypeSetFreeInternalRepProc, /* 694 */
Tcl_ObjTypeSetDupInternalRepProc, /* 695 */
Tcl_ObjTypeSetUpdateStringProc, /* 696 */
Tcl_ObjTypeSetSetFromAnyProc, /* 697 */
Tcl_ObjTypeSetVersion, /* 698 */
Tcl_ObjInterfaceSetFnListAll, /* 699 */
Tcl_ObjInterfaceSetFnListAppend, /* 700 */
Tcl_ObjInterfaceSetFnListAppendList, /* 701 */
Tcl_ObjInterfaceSetFnListIndex, /* 702 */
Tcl_ObjInterfaceSetFnListIndexEnd, /* 703 */
Tcl_ObjInterfaceSetFnListIsSorted, /* 704 */
Tcl_ObjInterfaceSetFnListLength, /* 705 */
Tcl_ObjInterfaceSetFnListRange, /* 706 */
Tcl_ObjInterfaceSetFnListRangeEnd, /* 707 */
Tcl_ObjInterfaceSetFnListReplace, /* 708 */
Tcl_ObjInterfaceSetFnListReplaceList, /* 709 */
Tcl_ObjInterfaceSetFnListReverse, /* 710 */
Tcl_ObjInterfaceSetFnListSet, /* 711 */
Tcl_ObjInterfaceSetFnListSetDeep, /* 712 */
Tcl_ObjInterfaceSetFnStringIndex, /* 713 */
Tcl_ObjInterfaceSetFnStringIndexEnd, /* 714 */
Tcl_ObjInterfaceSetFnStringLength, /* 715 */
Tcl_ObjInterfaceSetFnStringRange, /* 716 */
Tcl_ObjInterfaceSetFnStringRangeEnd, /* 717 */
Tcl_ObjTypeSetInterface, /* 718 */
Tcl_ObjTypeSetName, /* 719 */
Tcl_ObjInterfaceSetFnStringIsEmpty, /* 720 */
Tcl_ObjInterfaceSetFnListContains, /* 721 */
};
/* !END!: Do not edit above this line. */
|
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. */ #include "tclInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; MODULE_SCOPE const TclPlatStubs *tclPlatStubsPtr; MODULE_SCOPE const TclIntStubs *tclIntStubsPtr; MODULE_SCOPE const TclIntPlatStubs *tclIntPlatStubsPtr; MODULE_SCOPE void *tclStubsHandle; |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
count += !ISDIGIT(*p++);
}
if (count == 1) {
const char *q = actualVersion;
p = version;
while (*p && (*p == *q)) {
| | > | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
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, tclName, version, 1, NULL);
return NULL;
}
} else {
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclStubLibTbl.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. */ #include "tclInt.h" MODULE_SCOPE void *tclStubsHandle; /* *---------------------------------------------------------------------- * |
| ︙ | ︙ |
1 | /* | < < < < < < < > > > > | > > > | > > > > > > > > > > | < > > | 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 © 1993-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-2000 Ajuba Solutions. * Copyright © 2003 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclTest.c -- * * This file contains C command functions for a bunch of additional Tcl * commands that are used for testing out Tcl's C interfaces. These * commands are not normally included in Tcl applications; they're only * used for testing. */ #undef STATIC_BUILD # undef BUILD_tcl # ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #undef TCLBOOLWARNING #define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ #include "tclOO.h" #include <math.h> /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" |
| ︙ | ︙ | |||
506 507 508 509 510 511 512 | #endif #ifdef PURIFY ".purify" #endif #ifdef STATIC_BUILD ".static" #endif | < < < | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
#endif
#ifdef PURIFY
".purify"
#endif
#ifdef STATIC_BUILD
".static"
#endif
;
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
Tcl_CmdInfo info;
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
| < < | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
| > > > > > > | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (TcltestObjectInterfaceInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if (TcltestObjectInterfaceListIntegerInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
{
Tcl_CmdInfo info;
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
| < < | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 |
{
Tcl_CmdInfo info;
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
|
| ︙ | ︙ | |||
2047 2048 2049 2050 2051 2052 2053 | /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ static void SpecialFree( | < < < < | 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 |
/*
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(
void *blockPtr /* Block to free. */
) {
Tcl_Free(((char *)blockPtr) - 16);
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3807 3808 3809 3810 3811 3812 3813 |
TestlistrepCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/* Subcommands supported by this command */
| | | 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 |
TestlistrepCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"new",
"describe",
"config",
"validate",
NULL
};
enum {
|
| ︙ | ︙ | |||
5741 5742 5743 5744 5745 5746 5747 |
TestbytestringObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
struct {
| < < < < > > > > > | 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 |
TestbytestringObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
struct {
Tcl_Size n;
int m; /* This variable should not be overwritten */
} x = {0, 1};
const char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
/* Next line produces a "warning: passing argument 3 of ... from incompatible pointer type",
* but that's on purpose: It's exactly what we are testing here */
p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n);
if (p == NULL) {
return TCL_ERROR;
}
#if !defined(TCL_NO_DEPRECATED) && defined(__clang__)
# pragma clang diagnostic pop
#endif
if (x.m != 1) {
Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (char *)NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n));
return TCL_OK;
|
| ︙ | ︙ |
|
| > > > > > > | > > > > > > > > > | < < < < | | | < < < | < < | < | < < < < < | < < < | > > > | | < < < < < < < | | | | < < < < < < < | < | < < < < < < | < < | < < < < < | < < < | < < < < | < < < < | < < < | < < < < < | < < | < < < < < < | < | < < < < < < < | | < < < < < < < | | < < < < < < < | | 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 |
/*
* Copyright © 2021, 2024 Nathan Coulter. All rights reserved.
*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* Functions to test abstract lists.
*
* tclTestABSList.c --
*/
#undef BUILD_tcl
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include <string.h>
#include <limits.h>
#include "tclInt.h"
/*
* Forward references
*/
Tcl_Obj *myNewLStringObj(Tcl_WideInt start,
Tcl_WideInt length);
static void freeRep(Tcl_Obj* alObj);
static Tcl_ObjInterfaceListSetDeepProc my_LStringObjSetElemR;
static Tcl_DupInternalRepProc DupLStringRep;
static Tcl_ObjInterfaceListLengthProc my_LStringObjLength;
static Tcl_ObjInterfaceListIndexProc my_LStringObjIndex;
static Tcl_ObjInterfaceListRangeProc my_LStringObjRange;
static Tcl_ObjInterfaceListReverseProc my_LStringObjReverse;
static Tcl_ObjInterfaceListReplaceProc my_LStringReplace;
static Tcl_ObjInterfaceListAllProc my_LStringGetElements;
static void lstringFreeElements(Tcl_Obj* lstringObj);
static Tcl_UpdateStringProc UpdateStringOfLString;
/*
* Internal Representation of an lstring type value
*/
typedef struct LString {
char *string; // NULL terminated utf-8 string
Tcl_Size strlen; // num bytes in string
Tcl_Size allocated; // num bytes allocated
Tcl_Obj**elements; // elements array, allocated when GetElements is
// called
} LString;
/*
* AbstractList definition of an lstring type
*/
static ObjectType lstringTypes[11] = {
{/*0*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*1*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*2*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*3*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*4*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*5*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*6*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*7*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*8*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*9*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
},
{/*10*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
2,
NULL
}
};
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | > | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
my_LStringObjLength(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *lstringObjPtr, Tcl_Size *lenPtr )
{
LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1;
*lenPtr = lstringRepPtr->strlen;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DupLStringRep --
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | return; } /* *---------------------------------------------------------------------- * | | | | | | > | | > | | > | | | | > | | | | > | | > | 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 |
return;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjSetElemR --
*
* Replace the element value at the given (nested) index with the
* valueObj provided. If the lstring obj is shared, a new list is
* created conntaining the modifed element.
*
* Results:
* The modifed lstring is returned, either new or original. If the
* index is invalid, NULL is returned, and an error is added to the
* interp, if provided.
*
* Side effects:
* A new obj may be created.
*
*----------------------------------------------------------------------
*/
static int
my_LStringObjSetElemR(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size numIndicies,
Tcl_Obj *const indices[],
Tcl_Obj *valueObj,
Tcl_Obj **resPtrPtr)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
Tcl_Size index;
int status;
Tcl_Obj *resPtr;
if (numIndicies > 1) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Multiple indices not supported by lstring."));
*resPtrPtr = NULL;
return TCL_ERROR;
}
status = Tcl_GetIntForIndex(interp, indices[0], lstringRepPtr->strlen, &index);
if (status != TCL_OK) {
resPtrPtr = NULL;
return TCL_ERROR;
}
resPtr = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj;
lstringRepPtr = (LString*)resPtr->internalRep.twoPtrValue.ptr1;
if (index >= lstringRepPtr->strlen) {
index = lstringRepPtr->strlen;
lstringRepPtr->strlen++;
lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1);
}
if (valueObj) {
const char newvalue = Tcl_GetString(valueObj)[0];
lstringRepPtr->string[index] = newvalue;
} else if (index < lstringRepPtr->strlen) {
/* Remove the char by sliding the tail of the string down */
char *sptr = &lstringRepPtr->string[index];
/* This is an overlapping copy, by definition */
lstringRepPtr->strlen--;
memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index));
}
// else do nothing
Tcl_InvalidateStringRep(resPtr);
*resPtrPtr = resPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjRange --
*
* Creates a new Obj with a slice of the src listPtr.
*
* Results:
* A new Obj is assigned to newObjPtr. Returns TCL_OK
*
* Side effects:
* A new Obj is created.
*
*----------------------------------------------------------------------
*/
int my_LStringObjRange(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size fromIdx,
Tcl_Size toIdx,
Tcl_Obj **resPtrPtr)
{
Tcl_Obj *rangeObj, *newObjPtr;
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
LString *rangeRep;
Tcl_WideInt len = toIdx - fromIdx + 1;
if (lstringRepPtr->strlen < fromIdx ||
lstringRepPtr->strlen < toIdx) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Range out of bounds "));
*resPtrPtr = NULL;
return TCL_ERROR;
}
if (len <= 0) {
// Return empty value;
newObjPtr = Tcl_NewObj();
} else {
rangeRep = (LString*)Tcl_Alloc(sizeof(LString));
rangeRep->allocated = len+1;
rangeRep->strlen = len;
rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated);
strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len);
rangeRep->string[len] = 0;
rangeRep->elements = NULL;
rangeObj = Tcl_NewObj();
Tcl_ObjInternalRep itr;
itr.twoPtrValue.ptr1 = rangeRep;
itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr);
if (rangeRep->strlen > 0) {
Tcl_InvalidateStringRep(rangeObj);
} else {
Tcl_InitStringRep(rangeObj, NULL, 0);
}
newObjPtr = rangeObj;
}
*resPtrPtr = newObjPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjReverse --
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | * Side effects: * A new Obj is created. * *---------------------------------------------------------------------- */ static int | | < < < | > | > > > > < < < < < | > | < | < < < < < < < < | 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 |
* Side effects:
* A new Obj is created.
*
*----------------------------------------------------------------------
*/
static int
my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj)
{
LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1;
Tcl_Size len;
char *srcp, *endp;
char temp;
(void)interp;
if (Tcl_IsShared(srcObj)) {
Tcl_Panic("%s called with shared object", "my_LStringObjReverse");
}
len = srcRep->strlen;
srcp = srcRep->string;
endp = &srcRep->string[len];
endp--;
while (srcp < endp) {
temp = *endp;
*endp-- = *srcp;
*srcp++ = temp;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringReplace --
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
return TCL_OK;
}
static const Tcl_ObjType *
my_SetAbstractProc(int ptype)
{
| | | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
return TCL_OK;
}
static const Tcl_ObjType *
my_SetAbstractProc(int ptype)
{
const ObjectType *typePtr = &lstringTypes[0]; /* default value */
if (4 <= ptype && ptype <= 11) {
/* Table has no entries for the slots upto setfromany */
typePtr = &lstringTypes[(ptype-3)];
}
return (Tcl_ObjType *)typePtr;
}
/*
*----------------------------------------------------------------------
*
* my_NewLStringObj --
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
static const char* procTypeNames[] = {
"FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY",
"LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
"SETELEMENT", "REPLACE", NULL
};
int i = 0;
int ptype;
| | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
static const char* procTypeNames[] = {
"FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY",
"LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
"SETELEMENT", "REPLACE", NULL
};
int i = 0;
int ptype;
const Tcl_ObjType *lstringTypePtr = (Tcl_ObjType *)&lstringTypes[10];
repSize = sizeof(LString);
lstringRepPtr = (LString*)Tcl_Alloc(repSize);
while (i<objc) {
const char *s = Tcl_GetString(objv[i]);
if (strcmp(s, "-not")==0) {
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
*/
static void
UpdateStringOfLString(Tcl_Obj *objPtr)
{
# define LOCAL_SIZE 64
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
| < | > | | > | > | 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 |
*/
static void
UpdateStringOfLString(Tcl_Obj *objPtr)
{
# define LOCAL_SIZE 64
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
char *p;
int bytesNeeded = 0;
int status;
Tcl_Size i ,llen;
/*
* Handle empty list case first, so rest of the routine is simpler.
*/
status = my_LStringObjLength(NULL, objPtr, &llen);
if ((status != TCL_OK) || llen <= 0) {
Tcl_InitStringRep(objPtr, NULL, 0);
return;
}
/*
* Pass 1: estimate space.
*/
if (llen <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
}
for (bytesNeeded = 0, i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
my_LStringObjIndex(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
/* Note TclScanElement updates flagPtr[i] */
bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
p = objPtr->bytes;
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
| | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
p = objPtr->bytes;
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
my_LStringObjIndex(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
*p++ = ' ';
Tcl_DecrRefCount(elemObj);
}
p[-1] = '\0'; /* Overwrite last space added */
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 |
}
return elemObj;
}
/*
* Abstract List Length function
*/
| | | | > | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
}
return elemObj;
}
/*
* Abstract List Length function
*/
static int
lgenSeriesObjLength(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr, Tcl_Size *lenPtr)
{
LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1;
*lenPtr = lgenSeriesRepPtr->len;
return TCL_OK;
}
/*
* Abstract List Index function
*/
static int
lgenSeriesObjIndex(
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); /* * Abstract List ObjType definition */ | | > < < < > | < < < < < > > > | | 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 |
static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
/*
* Abstract List ObjType definition
*/
static ObjectType lgenObjectType = {
"lgenseries",
FreeLgenInternalRep,
DupLgenSeriesRep,
UpdateStringOfLgen,
NULL, /* SetFromAnyProc */
0,
NULL
};
static Tcl_ObjType *lgenTypePtr = (Tcl_ObjType *)&lgenObjectType;
/*
* ObjType Duplicate Internal Rep Function
*/
static void
DupLgenSeriesRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1;
Tcl_Size repSize = sizeof(LgenSeries);
LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize);
copyLgenSeries->interp = srcLgenSeries->interp;
copyLgenSeries->nargs = srcLgenSeries->nargs;
copyLgenSeries->len = srcLgenSeries->len;
copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj);
Tcl_IncrRefCount(copyLgenSeries->genFnObj);
copyPtr->typePtr = lgenTypePtr;
copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
return;
}
/*
* Create a new lgen Tcl_Obj
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 |
lGenSeriesRepPtr->nargs = objc;
lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1);
// Addd 0 placeholder for index
Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0));
Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj);
lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr;
lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
| | | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 |
lGenSeriesRepPtr->nargs = objc;
lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1);
// Addd 0 placeholder for index
Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0));
Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj);
lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr;
lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
lGenSeriesObj->typePtr = lgenTypePtr;
if (length > 0) {
Tcl_InvalidateStringRep(lGenSeriesObj);
} else {
Tcl_InitStringRep(lGenSeriesObj, NULL, 0);
}
return lGenSeriesObj;
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
*----------------------------------------------------------------------
*/
int Tcl_ABSListTest_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
int Tcl_ABSListTest_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
Tcl_ObjInterface *lgenIfPtr ,*lstringfullPtr ,*lstringNoLengthPtr ,*lstringNoIndexPtr
,*lstringNoRangePtr ,*lstringNoGetElementsPtr
,*lstringNoSetElementRPtr ,*lstringNoReplacePtr
;
lstringfullPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(lstringfullPtr ,1);
Tcl_ObjInterfaceSetFnListAll(lstringfullPtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListIndex(lstringfullPtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListLength(lstringfullPtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListRange(lstringfullPtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReplace(lstringfullPtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringfullPtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringfullPtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[0], lstringfullPtr);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[4], lstringfullPtr);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[8], lstringfullPtr);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[9], lstringfullPtr);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[10], lstringfullPtr);
lstringNoLengthPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListAll(lstringNoLengthPtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListIndex(lstringNoLengthPtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListRange(lstringNoLengthPtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReplace(lstringNoLengthPtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringNoLengthPtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringNoLengthPtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[1], lstringNoLengthPtr);
lstringNoIndexPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListAll(lstringNoIndexPtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListLength(lstringNoIndexPtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListRange(lstringNoIndexPtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReplace(lstringNoIndexPtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringNoIndexPtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringNoIndexPtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[2], lstringNoIndexPtr);
lstringNoRangePtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnListAll(lstringNoRangePtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListIndex(lstringNoRangePtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListLength(lstringNoRangePtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListReplace(lstringNoRangePtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringNoRangePtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringNoRangePtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[3], lstringNoRangePtr);
lstringNoGetElementsPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(lstringNoGetElementsPtr ,1);
Tcl_ObjInterfaceSetFnListIndex(lstringNoGetElementsPtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListLength(lstringNoGetElementsPtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListRange(lstringNoGetElementsPtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReplace(lstringNoGetElementsPtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringNoGetElementsPtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringNoGetElementsPtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[5], lstringNoGetElementsPtr);
lstringNoSetElementRPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(lstringNoSetElementRPtr ,1);
Tcl_ObjInterfaceSetFnListAll(lstringNoSetElementRPtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListIndex(lstringNoSetElementRPtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListLength(lstringNoSetElementRPtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListRange(lstringNoSetElementRPtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReplace(lstringNoSetElementRPtr ,my_LStringReplace);
Tcl_ObjInterfaceSetFnListReverse(lstringNoSetElementRPtr ,my_LStringObjReverse);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[6], lstringfullPtr);
lstringNoReplacePtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(lstringNoReplacePtr ,1);
Tcl_ObjInterfaceSetFnListAll(lstringNoReplacePtr , my_LStringGetElements);
Tcl_ObjInterfaceSetFnListIndex(lstringNoReplacePtr ,my_LStringObjIndex);
Tcl_ObjInterfaceSetFnListLength(lstringNoReplacePtr ,my_LStringObjLength);
Tcl_ObjInterfaceSetFnListRange(lstringNoReplacePtr ,my_LStringObjRange);
Tcl_ObjInterfaceSetFnListReverse(lstringNoReplacePtr ,my_LStringObjReverse);
Tcl_ObjInterfaceSetFnListSetDeep(lstringNoReplacePtr ,my_LStringObjSetElemR);
Tcl_ObjTypeSetInterface((Tcl_ObjType *)&lstringTypes[7], lstringNoReplacePtr);
lgenIfPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(lgenIfPtr ,1);
Tcl_ObjInterfaceSetFnListIndex(lgenIfPtr ,lgenSeriesObjIndex);
Tcl_ObjInterfaceSetFnListLength(lgenIfPtr ,lgenSeriesObjLength);
Tcl_ObjTypeSetInterface(lgenTypePtr, lgenIfPtr);
Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
return TCL_OK;
}
|
1 | /* | < < < < < < < > > > > | > > > > > > > > > > > > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1995-1998 Sun Microsystems, Inc.
* Copyright © 1999 Scriptics Corporation.
* Copyright © 2005 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclTestObj.c --
*
* This file contains procedures for the additional Tcl commands
* that are used for testing implementations of the Tcl_ObjType structs.
* These commands are built into a separate Tcl executable used to run the
* tests.
*/
#ifndef USE_TCL_STUBS
# undef BUILD_tcl
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#ifdef TCL_WITH_EXTERNAL_TOMMATH
# include "tommath.h"
#else
# include "tclTomMath.h"
#endif
#include "tclStringRep.h"
#undef TCLBOOLWARNING
#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */
#include <assert.h>
/*
* Forward declarations for functions defined later in this file:
*/
static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, Tcl_Size varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
Tcl_Obj *obj, Tcl_Size *indexPtr);
static void SetVarToObj(Tcl_Obj **varPtr, Tcl_Size varIndex, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc TestbignumobjCmd;
static Tcl_ObjCmdProc TestbooleanobjCmd;
static Tcl_ObjCmdProc TestdoubleobjCmd;
static Tcl_ObjCmdProc TestindexobjCmd;
static Tcl_ObjCmdProc TestintobjCmd;
static Tcl_ObjCmdProc TestlistobjCmd;
static Tcl_ObjCmdProc TestobjCmd;
static Tcl_ObjCmdProc TeststringobjCmd;
static Tcl_ObjCmdProc TestbigdataCmd;
static int TestStringObjIsEmpty(tclObjTypeInterfaceArgsStringIsEmpty);
static int TestListObjLength(tclObjTypeInterfaceArgsListLength);
static void v2UpdateString(Tcl_Obj *objPtr);
static ObjectType v2TestListObjectType = {
"testlist", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
v2UpdateString, /* updateStringProc */
NULL, /* setFromAnyProc */
2, /* This is a version objType, which doesn't have an StringIsEmpty proc */
NULL
};
Tcl_ObjType *v2TestListTypePtr = (Tcl_ObjType *)&v2TestListObjectType;
static ObjectType v3TestListObjectType = {
"testlist2", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
3, /* This is a version objType, which doesn't have an StringIsEmpty proc */
NULL
};
Tcl_ObjType *v3TestListTypePtr = (Tcl_ObjType *)&v3TestListObjectType;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
static void
VarPtrDeleteProc(
void *clientData,
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | } /* *---------------------------------------------------------------------- * * TclObjTest_Init -- * | | | | | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
}
/*
*----------------------------------------------------------------------
*
* TclObjTest_Init --
*
* Creates additional commands that are used to test
* Tcl_Obj support.
*
* Results:
* Returns a standard Tcl completion code, and if an error occurs, leaves an
* error message in the interp result.
*
* Side effects:
* Creates new commands used by tests.
*
*----------------------------------------------------------------------
*/
int
TclObjTest_Init(
Tcl_Interp *interp)
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
if (!varPtr) {
return TCL_ERROR;
}
Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
NULL, NULL);
| > > > > > > > > > > > > > | 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 |
if (!varPtr) {
return TCL_ERROR;
}
Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
Tcl_ObjInterface * oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(oiPtr ,2);
Tcl_ObjInterfaceSetFnListLength(oiPtr , TestListObjLength);
Tcl_ObjTypeSetInterface(v2TestListTypePtr ,oiPtr);
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(oiPtr ,3);
Tcl_ObjInterfaceSetFnListLength(oiPtr , TestListObjLength);
Tcl_ObjInterfaceSetFnStringIsEmpty(oiPtr , TestStringObjIsEmpty);
Tcl_ObjTypeSetInterface(v3TestListTypePtr ,oiPtr);
Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
NULL, NULL);
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
static int
TestbignumobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
| | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
static int
TestbignumobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
"set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
enum options {
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
BIGNUM_RADIXSIZE
} idx;
int index;
|
| ︙ | ︙ | |||
895 896 897 898 899 900 901 |
TestlistobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
| | | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
TestlistobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* const subcommands[] = {
"set",
"get",
"replace",
"indexmemcheck",
"getelementsmemcheck",
"index",
NULL
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
| | | 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 |
return TCL_ERROR;
}
varPtr = GetVarPtr(interp);
if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
TCL_INDEX_TEMP_TABLE, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
}
for (i = 0; i < len; ++i) {
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
!= TCL_OK) {
return TCL_ERROR;
}
| > > | | | | | | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
}
for (i = 0; i < len; ++i) {
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objP);
Tcl_DecrRefCount(objP);
if (objP->refCount < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Tcl_ListObjIndex returned object with ref count < 0",
TCL_INDEX_NONE));
/* Keep looping since we are also looping for leaks */
}
Tcl_BounceRefCount(objP);
}
break;
case LISTOBJ_GETELEMENTSMEMCHECK:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 | * * Side effects: * Creates and frees objects. * *---------------------------------------------------------------------- */ | > > | > > > > > > > | | | | | | < < > | < | < < < | > > > | < < < | | | 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 |
*
* Side effects:
* Creates and frees objects.
*
*----------------------------------------------------------------------
*/
void v2UpdateString(Tcl_Obj *objPtr) {
char *val, *newval;
Tcl_Size size;
val = (char *)"hello";
size = strlen(val) + 1;
newval = (char *)Tcl_Alloc(size);
strcpy(newval, val);
newval[size] = 0;
objPtr->bytes = newval;
objPtr->length = size;
return;
}
static int TestListObjLength(
TCL_UNUSED(Tcl_Interp *)
,TCL_UNUSED(Tcl_Obj *)
,Tcl_Size *size
) {
*size = 100;
return TCL_OK;
}
static int TestStringObjIsEmpty(
TCL_UNUSED(Tcl_Interp *)
,TCL_UNUSED(Tcl_Obj*)
,int *res)
{
*res = 1;
return TCL_OK;
}
static int
TestobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Size varIndex, destIndex;
int i;
const Tcl_ObjType *targetType;
Tcl_Obj **varPtr;
const char *subcommands[] = {
"freeallvars", "bug3598580", "buge58d7e19e9",
"types", "objtype", "newobj", "set",
"assign", "convert", "duplicate",
"invalidateStringRep", "refcount", "type",
NULL
};
enum testobjCmdIndex {
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
Tcl_SetObjResult(interp, listObjPtr);
}
return TCL_OK;
case TESTOBJ_BUGE58D7E19E9:
if (objc != 3) {
goto wrongNumArgs;
} else {
| > > | > > | > > > > > > > > | 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 |
Tcl_SetObjResult(interp, listObjPtr);
}
return TCL_OK;
case TESTOBJ_BUGE58D7E19E9:
if (objc != 3) {
goto wrongNumArgs;
} else {
int v;
Tcl_GetIntFromObj(NULL, objv[2],&v);
Tcl_Obj *listObjPtr = Tcl_NewObj();
switch (v) {
case 2:
listObjPtr->typePtr = v2TestListTypePtr;
break;
case 3:
listObjPtr->typePtr = v3TestListTypePtr;
break;
default:
return TCL_ERROR;
}
Tcl_InvalidateStringRep(listObjPtr);
Tcl_SetObjResult(interp, listObjPtr);
}
return TCL_OK;
case TESTOBJ_TYPES:
if (objc != 2) {
goto wrongNumArgs;
} else {
|
| ︙ | ︙ |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 2021 Nathan Coulter
*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclTestObjInterface.c --
*
* This file contains C command functions for the additional Tcl commands
* that are used for testing implementations of the Tcl object types.
* These commands are not normally included in Tcl applications; they're
* only used for testing.
*/
#include "tcl.h"
#include "tclInt.h"
/*
* Prototypes for functions defined later in this file:
*/
typedef struct indexHex {
int refCount;
Tcl_Size offset;
} indexHex;
int TcltestObjectInterfaceInit(Tcl_Interp *interp);
int NewTestIndexHex (
ClientData, Tcl_Interp *interp, Tcl_Size argc, Tcl_Obj *const objv[]);
static void DupTestIndexHexInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeTestIndexHexInternalRep(Tcl_Obj *objPtr);
static int SetTestIndexHexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfTestIndexHex(Tcl_Obj *listPtr);
static Tcl_ObjInterfaceStringIndexProc indexHexListStringIndex;
static Tcl_ObjInterfaceStringIndexEndProc indexHexListStringIndexEnd;
static Tcl_ObjInterfaceStringLengthProc indexHexListStringLength;
static int indexHexStringListIndexFromStringIndex(
Tcl_Size *index, Tcl_Size *itemchars, Tcl_Size *totalitems);
static Tcl_ObjInterfaceStringRangeProc indexHexListStringRange;
static Tcl_ObjInterfaceStringRangeEndProc indexHexListStringRangeEnd;
static Tcl_ObjInterfaceListAllProc indexHexListObjGetElements;
static Tcl_ObjInterfaceListAppendProc indexHexListObjAppendElement;
static Tcl_ObjInterfaceListAppendlistProc indexHexListObjAppendList;
static Tcl_ObjInterfaceListIndexProc indexHexListObjIndex;
static Tcl_ObjInterfaceListIndexEndProc indexHexListObjIndexEnd;
static Tcl_ObjInterfaceListIsSortedProc indexHexListObjIsSorted;
static Tcl_ObjInterfaceListLengthProc indexHexListObjLength;
static Tcl_ObjInterfaceListRangeProc indexHexListObjRange;
static Tcl_ObjInterfaceListRangeEndProc indexHexListObjRangeEnd;
static Tcl_ObjInterfaceListReplaceProc indexHexListObjReplace;
static Tcl_ObjInterfaceListSetProc indexHexListObjSet;
static Tcl_ObjInterfaceListSetDeepProc indexHexListObjSetDeep;
static int indexHexListErrorIndeterminate (Tcl_Interp *interp);
static int indexHexListErrorReadOnly (Tcl_Interp *interp);
Tcl_ObjType *testIndexHexTypePtr;
int TcltestObjectInterfaceInit(Tcl_Interp *interp) {
testIndexHexTypePtr = Tcl_NewObjType();
Tcl_ObjTypeSetName(testIndexHexTypePtr ,(char *)"testindexHex");
Tcl_ObjTypeSetFreeInternalRepProc(testIndexHexTypePtr , FreeTestIndexHexInternalRep);
Tcl_ObjTypeSetDupInternalRepProc(testIndexHexTypePtr, DupTestIndexHexInternalRep);
Tcl_ObjTypeSetUpdateStringProc(testIndexHexTypePtr, UpdateStringOfTestIndexHex);
Tcl_ObjTypeSetSetFromAnyProc(testIndexHexTypePtr ,SetTestIndexHexFromAny);
Tcl_ObjTypeSetVersion(testIndexHexTypePtr ,2);
Tcl_ObjInterface * oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetVersion(oiPtr ,1);
Tcl_ObjInterfaceSetFnStringIndex(oiPtr ,indexHexListStringIndex);
Tcl_ObjInterfaceSetFnStringIndexEnd(oiPtr ,indexHexListStringIndexEnd);
Tcl_ObjInterfaceSetFnStringLength(oiPtr ,indexHexListStringLength);
Tcl_ObjInterfaceSetFnStringRange(oiPtr ,indexHexListStringRange);
Tcl_ObjInterfaceSetFnStringRangeEnd(oiPtr ,indexHexListStringRangeEnd);
Tcl_ObjInterfaceSetFnListAll(oiPtr ,indexHexListObjGetElements);
Tcl_ObjInterfaceSetFnListAppend(oiPtr ,indexHexListObjAppendElement);
Tcl_ObjInterfaceSetFnListAppendList(oiPtr ,indexHexListObjAppendList);
Tcl_ObjInterfaceSetFnListIndex(oiPtr ,indexHexListObjIndex);
Tcl_ObjInterfaceSetFnListIndexEnd(oiPtr ,indexHexListObjIndexEnd);
Tcl_ObjInterfaceSetFnListIsSorted(oiPtr ,indexHexListObjIsSorted);
Tcl_ObjInterfaceSetFnListLength(oiPtr ,indexHexListObjLength);
Tcl_ObjInterfaceSetFnListRange(oiPtr ,indexHexListObjRange);
Tcl_ObjInterfaceSetFnListRangeEnd(oiPtr ,indexHexListObjRangeEnd);
Tcl_ObjInterfaceSetFnListReplace(oiPtr ,indexHexListObjReplace);
Tcl_ObjInterfaceSetFnListSet(oiPtr ,indexHexListObjSet);
Tcl_ObjInterfaceSetFnListSetDeep(oiPtr ,indexHexListObjSetDeep);
Tcl_ObjTypeSetInterface(testIndexHexTypePtr ,oiPtr);
Tcl_CreateObjCommand2(interp, "testindexhex", NewTestIndexHex, NULL, NULL);
return TCL_OK;
}
int NewTestIndexHex (
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_Size argc,
Tcl_Obj *const objv[])
{
Tcl_WideInt offset;
Tcl_ObjInternalRep intrep;
if (argc > 2) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("too many arguments", -1));
return TCL_ERROR;
}
}
if (argc == 2) {
if (Tcl_GetWideIntFromObj(interp, objv[1], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad offset", -1));
return TCL_ERROR;
}
} else {
offset = 0;
}
Tcl_Obj *objPtr = Tcl_NewObj();
Tcl_InvalidateStringRep(objPtr);
indexHex *indexHexPtr = (indexHex *)Tcl_Alloc(sizeof(indexHex));
indexHexPtr->refCount = 1;
indexHexPtr->offset = offset;
intrep.twoPtrValue.ptr1 = indexHexPtr;
Tcl_StoreInternalRep(objPtr, testIndexHexTypePtr, &intrep);
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
static void
DupTestIndexHexInternalRep(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj *))
{
return;
}
static void
FreeTestIndexHexInternalRep(Tcl_Obj *objPtr)
{
indexHex *indexHexPtr = (indexHex *)objPtr->internalRep.twoPtrValue.ptr1;
if (--indexHexPtr->refCount == 0) {
Tcl_Free(indexHexPtr);
}
return;
}
static int
SetTestIndexHexFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr)
{
if (TclHasInternalRep(objPtr, testIndexHexTypePtr)) {
return TCL_OK;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("can not set an existing value to this type", -1));
}
return TCL_ERROR;
}
}
static void
UpdateStringOfTestIndexHex(
TCL_UNUSED(Tcl_Obj *))
{
return;
}
static int indexHexListStringIndex(tclObjTypeInterfaceArgsStringIndex) {
Tcl_Obj *hexPtr;
int status;
Tcl_Size itemchars, totalitems;
status = indexHexStringListIndexFromStringIndex(
&index, &itemchars, &totalitems);
if (status != TCL_OK) {
return TCL_ERROR;
}
status = indexHexListObjIndex(interp, objPtr, totalitems, &hexPtr);
if (status != TCL_OK) {
return TCL_ERROR;
}
if (index == itemchars - 1) {
/* index refers to the space delimiter after the item. */
*resPtrPtr = Tcl_NewStringObj(" ", -1);
} else {
*resPtrPtr = Tcl_GetRange(hexPtr, index, index);
}
Tcl_DecrRefCount(hexPtr);
return status;
}
static int indexHexListErrorIndeterminate (Tcl_Interp *interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list length indeterminate", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "INDETERMINATE", NULL);
return TCL_ERROR;
}
static int indexHexListErrorReadOnly (Tcl_Interp *interp) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list length indeterminate", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "INTERFACE",
"READONLY", NULL);
}
return TCL_ERROR;
}
static int indexHexStringListIndexFromStringIndex(
Tcl_Size *indexPtr, Tcl_Size *itemcharsPtr, Tcl_Size *totalitemsPtr)
{
Tcl_Size itemoffset, last = 0, power = 1, lasttotalchars = 0, newitems,
top, totalchars = 0;
/* add 1 for the space after the item */
*itemcharsPtr = power + 1;
*totalitemsPtr = 0;
/* Count the number of characters in the items that contain fewer
* characters than the item containing the requested index. */
while (1) {
top = 1u << (4 * power);
if (top < 1u << (4 * (power - 1))) {
/* operation wrapped around */
power -= 1;
break;
}
newitems = top - last;
lasttotalchars = totalchars;
totalchars += newitems * *itemcharsPtr;
last = top;
if (*indexPtr < totalchars) {
break;
}
power += 1;
*itemcharsPtr += 1;
*totalitemsPtr += newitems;
}
*indexPtr -= lasttotalchars;
/* Determine how many items containing the same number of characters
* precede the requested item. */
itemoffset = *indexPtr / *itemcharsPtr ;
*indexPtr = *indexPtr % *itemcharsPtr;
/* Add the number of new characters. */
*totalitemsPtr += itemoffset;
return TCL_OK;
}
static int indexHexListStringIndexEnd(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Size),
TCL_UNUSED(Tcl_Obj **)
) {
return indexHexListErrorIndeterminate(interp);
}
static int indexHexListStringLength(
TCL_UNUSED(Tcl_Obj *)
,Tcl_Size *length
) {
*length = -1;
return TCL_ERROR;
}
static int indexHexListStringRange(tclObjTypeInterfaceArgsStringRange) {
Tcl_Obj *itemPtr, *item2Ptr, *resPtr;
Tcl_Size index = first, status;
Tcl_Size itemchars, needed, rangeLength, newStringLength,
stringLength, totalitems;
if (last < first) {
*resPtrPtr = Tcl_NewStringObj("", -1);
return TCL_OK;
}
status = indexHexStringListIndexFromStringIndex(
&index, &itemchars, &totalitems);
if (status != TCL_OK) {
return status;
}
status = indexHexListObjIndex(NULL, objPtr, totalitems, &itemPtr);
if (status != TCL_OK) {
return status;
}
rangeLength = last - first + 1;
resPtr = Tcl_GetRange(itemPtr, index, index + rangeLength - 1);
Tcl_DecrRefCount(itemPtr);
stringLength = Tcl_GetCharLength(resPtr);
if (stringLength < rangeLength) {
needed = rangeLength - stringLength;
while (needed > 0) {
totalitems++;
status = indexHexListObjIndex(NULL, objPtr, totalitems, &itemPtr);
if (status != TCL_OK) {
return status;
}
Tcl_AppendToObj(resPtr, " ", 1);
stringLength += newStringLength;
needed -= 1;
if (needed > 0) {
newStringLength = Tcl_GetCharLength(itemPtr);
if (newStringLength >= needed) {
item2Ptr = Tcl_GetRange(itemPtr, 0, needed-1);
newStringLength = Tcl_GetCharLength(item2Ptr);
Tcl_AppendObjToObj(resPtr, item2Ptr);
Tcl_DecrRefCount(item2Ptr);
} else {
Tcl_AppendObjToObj(resPtr, itemPtr);
}
stringLength += newStringLength;
needed -= newStringLength;
}
Tcl_DecrRefCount(itemPtr);
}
}
*resPtrPtr = resPtr;
return TCL_OK;
}
static int indexHexListStringRangeEnd(
TCL_UNUSED(Tcl_Obj *),/* The Tcl object to find the range of. */
TCL_UNUSED(Tcl_Size),/* First index of the range. */
TCL_UNUSED(Tcl_Size), /* Last index of the range. */
Tcl_Obj **resultPtr
) {
*resultPtr = NULL;
return TCL_OK;
}
static int
indexHexListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
TCL_UNUSED(Tcl_Obj *),/* List object for which an element array
* is to be returned. */
TCL_UNUSED(Tcl_Size *),/* Where to store the count of objects
* referenced by objv. */
TCL_UNUSED(Tcl_Obj ***)/* Where to store the pointer to an
* array of */
)
{
if (interp != NULL) {
Tcl_SetObjResult(interp,Tcl_NewStringObj("infinite list", -1));
}
return TCL_ERROR;
}
static int
indexHexListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
TCL_UNUSED(Tcl_Obj *),/* List object to append objPtr to. */
TCL_UNUSED(Tcl_Obj *)/* Object to append to listPtr's list. */
)
{
indexHexListErrorReadOnly(interp);
return TCL_ERROR;
}
static int
indexHexListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
TCL_UNUSED(Tcl_Obj *), /* List object to append elements to. */
TCL_UNUSED(Tcl_Obj *) /* List obj with elements to append. */
)
{
indexHexListErrorReadOnly(interp);
return TCL_ERROR;
}
static int
indexHexListObjIndex(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *), /* List object to index into. */ \
Tcl_Size index, /* Index of element to return. */ \
Tcl_Obj **objPtrPtr /* The resulting Tcl_Obj* is stored here. */
)
{
Tcl_Obj *resPtr;
resPtr = Tcl_ObjPrintf("%" TCL_T_MODIFIER "x", index);
*objPtrPtr = resPtr;
return TCL_OK;
}
static int
indexHexListObjIndexEnd(
Tcl_Interp * interp,/* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *),/* List object to index into. */ \
TCL_UNUSED(Tcl_Size),/* Index of element to return. */ \
TCL_UNUSED(Tcl_Obj **)/* The resulting Tcl_Obj* is stored here. */
)
{
return indexHexListErrorIndeterminate(interp);
}
static int indexHexListObjIsSorted(
TCL_UNUSED(Tcl_Interp *), /* Used to report errors */
TCL_UNUSED(Tcl_Obj *), /* The list in question */
TCL_UNUSED(size_t) /* flags */
)
{
return 1;
}
static int
indexHexListObjLength(
TCL_UNUSED(Tcl_Interp *), /* Used to report errors if not NULL. */
TCL_UNUSED(Tcl_Obj *), /* List object whose #elements to return. */
Tcl_Size *lenPtr /* The resulting length is stored here. */
)
{
*lenPtr = -1;
return TCL_OK;
}
static int
indexHexListObjRange(tclObjTypeInterfaceArgsListRange)
{
Tcl_Obj *itemPtr, *resPtr;
Tcl_Size length;
int status;
resPtr = Tcl_NewListObj(0, NULL);
status = Tcl_ListObjLength(interp, listPtr, &length);
if (!status) {
*resPtrPtr = NULL;
return TCL_OK;
}
while (fromIdx <= length && fromIdx <= toIdx) {
indexHexListObjIndex(interp, listPtr, fromIdx, &itemPtr);
if (
Tcl_ListObjAppendElement(interp, resPtr, itemPtr) != TCL_OK
) {
Tcl_DecrRefCount(resPtr);
*resPtrPtr = NULL;
return TCL_OK;
}
fromIdx++;
}
*resPtrPtr = resPtr;
return TCL_OK;
}
static int
indexHexListObjRangeEnd(tclObjTypeInterfaceArgsListRangeEnd) {
if (fromAnchor == 1 || toAnchor == 1) {
indexHexListErrorIndeterminate(interp);
*resPtrPtr = NULL;
return TCL_OK;
}
return indexHexListObjRange(interp, listPtr, fromIdx, toIdx, resPtrPtr);
}
static int
indexHexListObjReplace(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */ \
TCL_UNUSED(Tcl_Obj *), /* List object whose elements to replace. */ \
TCL_UNUSED(Tcl_Size), /* Index of first element to replace. */ \
TCL_UNUSED(Tcl_Size), /* Number of elements to replace. */ \
TCL_UNUSED(Tcl_Size), /* Number of objects to insert. */ \
/* An array of objc pointers to Tcl \
* objects to insert. */ \
TCL_UNUSEDVAR(Tcl_Obj *const insertObjs[])
)
{
indexHexListErrorReadOnly(interp);
return TCL_ERROR;
}
static int
indexHexListObjSet(
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting
* if not NULL. */
TCL_UNUSED(Tcl_Obj *), /* List object in which element should be
* stored. */
TCL_UNUSED(Tcl_Size), /* Index of element to store. */
TCL_UNUSED(Tcl_Obj *)/* Tcl object to store in the designated list
* element. */
)
{
indexHexListErrorReadOnly(interp);
return TCL_ERROR;
}
static int indexHexListObjSetDeep (
Tcl_Interp *interp, /* Tcl interpreter. */ \
TCL_UNUSED(Tcl_Obj *), /* Pointer to the list being modified. */ \
TCL_UNUSED(Tcl_Size), /* Number of index args. */ \
TCL_UNUSEDVAR(Tcl_Obj *const indexArray[]), /* Index args. */ \
TCL_UNUSED(Tcl_Obj *), /* Value arg to 'lset' or NULL to 'lpop'. */
Tcl_Obj **resPtrPtr)
{
indexHexListErrorReadOnly(interp);
*resPtrPtr = NULL;
return TCL_ERROR;
}
|
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 2021 Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclTestObjInterfce.c --
*
* This file contains C command functions for the additional Tcl commands
* that are used for testing implementations of the Tcl object types.
* These commands are not normally included in Tcl applications; they're
* only used for testing.
*/
#include "tcl.h"
#include "tclInt.h"
/*
* Prototypes for functions defined later in this file:
*/
int TestListInteger (
ClientData, Tcl_Interp *interp, Tcl_Size argc, Tcl_Obj *const objv[]);
static Tcl_Obj* NewTestListInteger();
static void DupTestListIntegerInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeTestListIntegerInternalRep(Tcl_Obj *objPtr);
static int SetTestListIntegerFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfTestListInteger(Tcl_Obj *listPtr);
int TestListIntegerGetElements(TCL_UNUSED(void *), Tcl_Interp *interp,
Tcl_Size argc, Tcl_Obj *const objv[]);
static Tcl_ObjInterfaceStringIndexProc ListIntegerListStringIndex;
static Tcl_ObjInterfaceStringIndexEndProc ListIntegerListStringIndexEnd;
static Tcl_ObjInterfaceStringLengthProc ListIntegerListStringLength;
/*
static int ListIntegerStringListIndexFromStringIndex(
Tcl_Size *index, Tcl_Size *itemchars, Tcl_Size *totalitems);
*/
static Tcl_ObjInterfaceStringRangeProc ListIntegerListStringRange;
static Tcl_ObjInterfaceStringRangeEndProc ListIntegerListStringRangeEnd;
static Tcl_ObjInterfaceListAppendProc ListIntegerListObjAppendElement;
static Tcl_ObjInterfaceListAppendlistProc ListIntegerListObjAppendList;
static Tcl_ObjInterfaceListIndexProc ListIntegerListObjIndex;
static Tcl_ObjInterfaceListIndexEndProc ListIntegerListObjIndexEnd;
static Tcl_ObjInterfaceListIsSortedProc ListIntegerListObjIsSorted;
static Tcl_ObjInterfaceListLengthProc ListIntegerListObjLength;
static Tcl_ObjInterfaceListRangeProc ListIntegerListObjRange;
static Tcl_ObjInterfaceListRangeEndProc ListIntegerListObjRangeEnd;
static Tcl_ObjInterfaceListReplaceProc ListIntegerListObjReplace;
static Tcl_ObjInterfaceListReplaceListProc ListIntegerListObjReplaceList;
static Tcl_ObjInterfaceListSetProc ListIntegerLset;
static Tcl_ObjInterfaceListSetDeepProc ListIntegerListObjSetDeep;
static int ErrorMaxElementsExceeded(Tcl_Interp *interp);
typedef struct ListInteger {
int refCount;
int ownstring;
int size;
int used;
int values[1];
} ListInteger;
static ListInteger* NewTestListIntegerIntrep();
static ListInteger* ListGetInternalRep(Tcl_Obj *listPtr);
static void ListIntegerDecrRefCount(ListInteger *listIntegerPtr);
static ObjectType testListIntegerType = {
"testListInteger",
FreeTestListIntegerInternalRep, /* freeIntRepProc */
DupTestListIntegerInternalRep, /* dupIntRepProc */
UpdateStringOfTestListInteger, /* updateStringProc */
SetTestListIntegerFromAny, /* setFromAnyProc */
2,
NULL
};
Tcl_ObjType *testListIntegerTypePtr = (Tcl_ObjType *)&testListIntegerType;
int TcltestObjectInterfaceListIntegerInit(Tcl_Interp *interp) {
Tcl_ObjInterface *oiPtr;
oiPtr = Tcl_NewObjInterface();
Tcl_ObjInterfaceSetFnStringIndex(oiPtr ,ListIntegerListStringIndex);
Tcl_ObjInterfaceSetFnStringIndexEnd(oiPtr ,ListIntegerListStringIndexEnd);
Tcl_ObjInterfaceSetFnStringLength(oiPtr ,ListIntegerListStringLength);
Tcl_ObjInterfaceSetFnStringRange(oiPtr ,ListIntegerListStringRange);
Tcl_ObjInterfaceSetFnStringRangeEnd(oiPtr ,ListIntegerListStringRangeEnd);
Tcl_ObjInterfaceSetFnListAppend(oiPtr ,ListIntegerListObjAppendElement);
Tcl_ObjInterfaceSetFnListAppendList(oiPtr ,ListIntegerListObjAppendList);
Tcl_ObjInterfaceSetFnListIndex(oiPtr ,ListIntegerListObjIndex);
Tcl_ObjInterfaceSetFnListIndexEnd(oiPtr ,ListIntegerListObjIndexEnd);
Tcl_ObjInterfaceSetFnListIsSorted(oiPtr ,ListIntegerListObjIsSorted);
Tcl_ObjInterfaceSetFnListLength(oiPtr ,ListIntegerListObjLength);
Tcl_ObjInterfaceSetFnListRange(oiPtr ,ListIntegerListObjRange);
Tcl_ObjInterfaceSetFnListRangeEnd(oiPtr ,ListIntegerListObjRangeEnd);
Tcl_ObjInterfaceSetFnListReplace(oiPtr ,ListIntegerListObjReplace);
Tcl_ObjInterfaceSetFnListReplaceList(oiPtr ,ListIntegerListObjReplaceList);
Tcl_ObjInterfaceSetFnListSet(oiPtr , ListIntegerLset);
Tcl_ObjInterfaceSetFnListSetDeep(oiPtr ,ListIntegerListObjSetDeep);
Tcl_ObjTypeSetInterface(testListIntegerTypePtr,oiPtr);
Tcl_CreateObjCommand2(interp, "testlistinteger", TestListInteger, NULL, NULL);
Tcl_CreateObjCommand2(interp, "testlistintegergetelements", TestListIntegerGetElements, NULL, NULL);
return TCL_OK;
}
int TestListInteger(
TCL_UNUSED(void *),
Tcl_Interp *interp,
Tcl_Size argc,
Tcl_Obj *const objv[])
{
int status;
if (argc != 2) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong # arguments", -1));
}
return TCL_ERROR;
}
status = Tcl_ConvertToType(interp, objv[1], testListIntegerTypePtr);
Tcl_SetObjResult(interp, objv[1]);
return status;
}
int TestListIntegerGetElements(
TCL_UNUSED(void *),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(Tcl_Size),
TCL_UNUSED(Tcl_Obj * const *))
{
return 0;
}
Tcl_Obj*
NewTestListInteger() {
Tcl_ObjInternalRep intrep;
Tcl_Obj *listPtr = Tcl_NewObj();
Tcl_InvalidateStringRep(listPtr);
ListInteger *listIntegerPtr = NewTestListIntegerIntrep();
intrep.twoPtrValue.ptr1 = listIntegerPtr;
Tcl_StoreInternalRep(listPtr, testListIntegerTypePtr, &intrep);
return listPtr;
}
ListInteger*
NewTestListIntegerIntrep() {
ListInteger *listIntegerPtr = (ListInteger *)Tcl_Alloc(sizeof(ListInteger));
listIntegerPtr->refCount = 1;
listIntegerPtr->ownstring = 0;
listIntegerPtr->size = 1;
listIntegerPtr->used = 0;
return listIntegerPtr;
}
static ListInteger* ListGetInternalRep(Tcl_Obj *listPtr) {
return (ListInteger *)listPtr->internalRep.twoPtrValue.ptr1;
}
static void DupTestListIntegerInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) {
Tcl_ObjInternalRep intrep;
ListInteger *listRepPtr = ListGetInternalRep(srcPtr);
listRepPtr->refCount++;
intrep.twoPtrValue.ptr1 = listRepPtr;
Tcl_StoreInternalRep(copyPtr, testListIntegerTypePtr, &intrep);
return;
}
static void FreeTestListIntegerInternalRep(Tcl_Obj *listPtr) {
ListInteger *listRepPtr = ListGetInternalRep(listPtr);
ListIntegerDecrRefCount(listRepPtr);
return;
}
static int SetTestListIntegerFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
int status;
Tcl_Size i, length;
Tcl_Obj *itemPtr, *listPtr;
Tcl_ObjInternalRep intrep;
ListInteger *listRepPtr;
if (TclHasInternalRep(objPtr, testListIntegerTypePtr)) {
return TCL_OK;
} else {
status = Tcl_ListObjLength(interp, objPtr, &length);
if (status != TCL_OK) {
return TCL_ERROR;
}
listPtr = NewTestListInteger();
for (i = 0; i < length; i++) {
status = Tcl_ListObjIndex(interp, objPtr, i, &itemPtr);
if (status != TCL_OK) {
Tcl_DecrRefCount(listPtr);
return status;
}
status = ListIntegerListObjReplace(interp, listPtr, i, 0, 1, &itemPtr);
status = TCL_OK;
if (status != TCL_OK) {
Tcl_DecrRefCount(listPtr);
return status;
}
}
listRepPtr = ListGetInternalRep(listPtr);
intrep.twoPtrValue.ptr1 = listRepPtr;
listRepPtr->refCount++;
Tcl_StoreInternalRep(objPtr, testListIntegerTypePtr, &intrep);
Tcl_DecrRefCount(listPtr);
return TCL_OK;
}
}
static void UpdateStringOfTestListInteger(Tcl_Obj *listPtr) {
ListInteger *listRepPtr = ListGetInternalRep(listPtr);
int i, num, used = listRepPtr->used;
Tcl_Obj *strPtr, *numObjPtr;
if (used > 0) {
strPtr = Tcl_NewObj();
Tcl_IncrRefCount(strPtr);
num = listRepPtr->values[0];
numObjPtr = Tcl_NewIntObj(num);
Tcl_IncrRefCount(numObjPtr);
Tcl_AppendFormatToObj(NULL, strPtr, "%d", 1, &numObjPtr);
Tcl_DecrRefCount(numObjPtr);
for (i = 1; i < used; i++) {
num = listRepPtr->values[i];
numObjPtr = Tcl_NewIntObj(num);
Tcl_IncrRefCount(numObjPtr);
Tcl_AppendFormatToObj(NULL, strPtr, " %d", 1, &numObjPtr);
Tcl_DecrRefCount(numObjPtr);
}
listPtr->bytes = strPtr->bytes;
listPtr->length = strPtr->length;
strPtr->bytes = 0;
strPtr->length = 0;
Tcl_DecrRefCount(strPtr);
} else {
Tcl_InitStringRep(listPtr, NULL, 0);
}
listRepPtr->ownstring = 1;
return;
}
static void ListIntegerDecrRefCount(ListInteger *listIntegerPtr) {
if (--listIntegerPtr->refCount <= 0) {
Tcl_Free(listIntegerPtr);
}
return;
}
static int ListIntegerListStringIndex (
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *), /* List object to index into. */ \
TCL_UNUSED(Tcl_Size), /* Index of element to return. */ \
TCL_UNUSED(Tcl_Obj **)/* The resulting Tcl_Obj* is stored here. */
)
{
return TCL_ERROR;
}
static int ListIntegerListStringIndexEnd(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *),/* List object to index into. */ \
TCL_UNUSED(Tcl_Size),/* Index of element to return. */ \
TCL_UNUSED(Tcl_Obj **)/* The resulting Tcl_Obj* is stored here. */
) {
return TCL_ERROR;
}
static int ListIntegerListStringLength(
TCL_UNUSED(Tcl_Obj *)
,Tcl_Size *lengthPtr
) {
*lengthPtr = -1;
return TCL_ERROR;
}
/*
static int ListIntegerStringListIndexFromStringIndex(
TCL_UNUSEDVAR(Tcl_Size *index),
TCL_UNUSEDVAR(Tcl_Size *itemchars),
TCL_UNUSEDVAR(Tcl_Size *totalitems)
) {
return TCL_ERROR;
}
*/
static int ListIntegerListStringRange(
TCL_UNUSED(Tcl_Obj *), /* The Tcl object to find the range of. */ \
TCL_UNUSED(Tcl_Size), /* First index of the range. */ \
TCL_UNUSED(Tcl_Size), /* Last index of the range. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */
) {
*resPtrPtr = NULL;
return TCL_OK;
}
static int ListIntegerListStringRangeEnd(
TCL_UNUSED(Tcl_Obj *), /* The Tcl object to find the range of. */ \
TCL_UNUSED(Tcl_Size), /* First index of the range. */ \
TCL_UNUSED(Tcl_Size), /* Last index of the range. */ \
Tcl_Obj **resPtrPtr /* The resulting Tcl_Obj* is stored here. */)
{
*resPtrPtr = NULL;
return TCL_OK;
}
static int ListIntegerListObjAppendElement(tclObjTypeInterfaceArgsListAppend) {
int status;
Tcl_Size length;
status = Tcl_ListObjLength(interp, listPtr, &length);
if (status != TCL_OK) {
return TCL_ERROR;
}
return ListIntegerListObjReplace(interp, listPtr, length, 0, 1, &objPtr);
}
static int ListIntegerListObjAppendList(
TCL_UNUSEDVAR(Tcl_Interp *interp), /* Used to report errors if not NULL. */ \
TCL_UNUSEDVAR(Tcl_Obj *listPtr), /* List object to append elements to. */ \
TCL_UNUSEDVAR(Tcl_Obj *elemListPtr) /* List obj with elements to append. */
) {
return TCL_ERROR;
}
static int ListIntegerListObjIndex(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
Tcl_Obj * listObj,/* List object to index into. */ \
Tcl_Size index, /* Index of element to return. */ \
Tcl_Obj **objPtrPtr /* The resulting Tcl_Obj* is stored here. */
) {
ListInteger *listRepPtr = ListGetInternalRep(listObj);
Tcl_Size num;
if (index >= 0 && index < listRepPtr->used) {
num = listRepPtr->values[index];
*objPtrPtr = Tcl_NewLongObj(num);
} else {
*objPtrPtr = NULL;
}
return TCL_OK;
}
static int ListIntegerListObjIndexEnd(
TCL_UNUSED(Tcl_Interp *),/* Used to report errors if not NULL. */ \
TCL_UNUSED(Tcl_Obj *),/* List object to index into. */ \
TCL_UNUSED(Tcl_Size),/* Index of element to return. */ \
TCL_UNUSED(Tcl_Obj **)/* The resulting Tcl_Obj* is stored here. */
) {
return TCL_ERROR;
}
static int ListIntegerListObjIsSorted(
TCL_UNUSED(Tcl_Interp *), /* Used to report errors */
TCL_UNUSED(Tcl_Obj *), /* The list in question */
TCL_UNUSED(size_t) /* flags */
) {
return TCL_ERROR;
}
static int ListIntegerListObjLength(
TCL_UNUSED(Tcl_Interp *), /* Used to report errors if not NULL. */
Tcl_Obj * listObj, /* List object whose #elements to return. */
Tcl_Size *lenPtr /* The resulting length is stored here. */
) {
ListInteger *listRepPtr = ListGetInternalRep(listObj);
*lenPtr = listRepPtr->used;
return TCL_OK;
}
static int ListIntegerListObjRange(tclObjTypeInterfaceArgsListRange) {
ListInteger *listRepPtr = ListGetInternalRep(listPtr);
Tcl_Size i, j, num, used = listRepPtr->used;
Tcl_Obj *numObjPtr, *resPtr;
if ((fromIdx == 0 && toIdx >= used - 1) || used == 0) {
*resPtrPtr = listPtr;
return TCL_OK;
}
if (Tcl_IsShared(listPtr) ||
((listRepPtr->refCount > 1))) {
if (fromIdx >= used || toIdx < fromIdx) {
*resPtrPtr = Tcl_NewObj();
return TCL_OK;
} else {
resPtr = NewTestListInteger();
for (i = fromIdx, j = 0; i <= toIdx; i++, j++) {
num = listRepPtr->values[i];
numObjPtr = Tcl_NewIntObj(num);
Tcl_IncrRefCount(numObjPtr);
if (ListIntegerListObjReplace(
interp, resPtr, j , 0 , 1 ,&numObjPtr) != TCL_OK) {
Tcl_DecrRefCount(resPtr);
Tcl_DecrRefCount(numObjPtr);
*resPtrPtr = NULL;
return TCL_OK;
}
Tcl_DecrRefCount(numObjPtr);
}
*resPtrPtr = resPtr;
return TCL_OK;
}
}
*resPtrPtr = NULL;
return TCL_OK;
}
static int ListIntegerListObjRangeEnd(
TCL_UNUSEDVAR(Tcl_Interp * interp), /* Used to report errors */ \
TCL_UNUSEDVAR(Tcl_Obj *listPtr), /* List object to take a range from. */ \
TCL_UNUSEDVAR(Tcl_Size fromAnchor),/* 0 for start and 1 for end */ \
TCL_UNUSEDVAR(Tcl_Size fromIdx), /* Index of first element to include. */ \
TCL_UNUSEDVAR(Tcl_Size toAnchor), /* 0 for start and 1 for end */ \
TCL_UNUSEDVAR(Tcl_Size toIdx), /* Index of last element to include. */
Tcl_Obj **resPtrPtr
) {
*resPtrPtr = NULL;
return TCL_OK;
}
static int ListIntegerListObjReplace(tclObjTypeInterfaceArgsListReplace) {
int i, status;
Tcl_Obj *tmpListPtr = Tcl_NewObj();
Tcl_IncrRefCount(tmpListPtr);
for (i = 0; i < numToInsert; i++) {
status = Tcl_ListObjAppendElement(interp, tmpListPtr, insertObjs[i]);
if (status != TCL_OK) {
Tcl_DecrRefCount(tmpListPtr);
return status;
}
}
status = ListIntegerListObjReplaceList(
interp, listObj, first, numToDelete, tmpListPtr);
Tcl_DecrRefCount(tmpListPtr);
return status;
}
static int ListIntegerListObjReplaceList(tclObjTypeInterfaceArgsListReplaceList) {
ListInteger *listRepPtr = ListGetInternalRep(listPtr);
ListInteger *newListRepPtr;
int changed = 0, itemInt, status;
Tcl_Size i, index, newmemsize, itemsLength, j, newsize,
newtailindex, newused, size, newtailend, tailindex, tailsize,
used;
Tcl_Obj *itemPtr;
size = listRepPtr->size;
used = listRepPtr->used;
if (first < used) {
tailsize = used - first;
} else {
tailsize = 0;
}
status = Tcl_ListObjLength(interp, newItemsPtr, &itemsLength);
if (status != TCL_OK) {
return TCL_ERROR;
}
/* Currently this duplicates checks found in Tcl_ListObjReplace, but
* could be removed in that function in the future.
*/
if (first >= used) {
first = used;
} else if (first < 0) {
first = 0;
}
if (count > tailsize) {
count = tailsize;
}
/* If count == 0 and itemsLength == 0 this routine is logically a no-op,
* but any non-canonical string representation must still be invalidated.
*/
/* to do:
* Recode this routine to work with incoming of unbounded length
*/
if (used > 0) {
tailindex = first + count;
newtailindex = first + itemsLength;
if (INT_MAX - tailsize - 1 < newtailindex) {
return ErrorMaxElementsExceeded(interp);
}
newused = newtailindex + tailsize;
if (itemsLength > 0 && INT_MAX - itemsLength < newused) {
return ErrorMaxElementsExceeded(interp);
}
} else {
tailindex = 0;
newtailindex = 0;
newused = itemsLength;
}
if (newused > size && newused > 1) {
newsize = (newused + newused / 5 + 1);
if (newsize < size) {
return ErrorMaxElementsExceeded(interp);
}
} else {
newsize = size;
}
if (!listRepPtr->ownstring) {
/* schedule canonicalization of the string rep */
Tcl_InvalidateStringRep(listPtr);
listRepPtr->ownstring = 1;
}
if (newused < used) {
Tcl_InvalidateStringRep(listPtr);
}
newmemsize = sizeof(ListInteger) + newsize * sizeof(int) - sizeof(int);
if (listRepPtr->refCount > 1) {
Tcl_ObjInternalRep intrep;
/* copy only the structure and the head of the old array */
int movsize = sizeof(ListInteger)
+ ((first + 1) * sizeof(int) - sizeof(int));
newListRepPtr = (ListInteger *)Tcl_Alloc(newmemsize);
memmove(newListRepPtr, listRepPtr, movsize);
newListRepPtr->size = newsize;
newListRepPtr->refCount = 1;
/* move the tail to its new location to make room for the new additions
*/
memmove(newListRepPtr->values + newtailindex,
listRepPtr->values + tailindex, tailsize * sizeof(int));
intrep.twoPtrValue.ptr1 = newListRepPtr;
Tcl_StoreInternalRep(listPtr, testListIntegerTypePtr, &intrep);
} else {
if (newsize > size && newused > 1) {
newListRepPtr = (ListInteger *)Tcl_Realloc(listRepPtr, newmemsize);
} else {
newListRepPtr = listRepPtr;
}
newListRepPtr->size = newsize;
if (tailsize > 0 && tailindex != newtailindex) {
/* move the tail to its new location to make room for the new
* additions */
memmove(newListRepPtr->values + newtailindex,
newListRepPtr->values + tailindex, tailsize);
}
listPtr->internalRep.twoPtrValue.ptr1 = newListRepPtr;
}
i = -1;
while (1) {
i++;
index = first + i;
status = Tcl_ListObjIndex(interp, newItemsPtr, i, &itemPtr);
if (status != TCL_OK) {
return status;
}
if (itemPtr == NULL) {
break;
}
if (Tcl_GetIntFromObj(interp, itemPtr, &itemInt)
== TCL_OK) {
if (newListRepPtr->values[index] != itemInt) {
changed = 1;
newListRepPtr->values[index] = itemInt;
}
newListRepPtr->values[index] = itemInt;
} else {
Tcl_Obj *realListPtr;
/* Fall back to normal list */
realListPtr = Tcl_NewListObj(newsize, NULL);
Tcl_IncrRefCount(realListPtr);
for (j = 0; j < index; j++) {
itemPtr = Tcl_NewIntObj(newListRepPtr->values[j]);
status = Tcl_ListObjAppendElement(
interp, realListPtr, itemPtr);
if (status != TCL_OK) {
Tcl_DecrRefCount(realListPtr);
return status;
}
}
while (1) {
if (itemsLength == TCL_LENGTH_NONE) {
status = Tcl_ListObjLength(interp, newItemsPtr, &itemsLength);
if (status != TCL_OK) {
Tcl_DecrRefCount(realListPtr);
return status;
}
}
if (itemsLength != TCL_LENGTH_NONE && i >= itemsLength) {
break;
}
status = Tcl_ListObjIndex(interp, newItemsPtr, i, &itemPtr);
if (status != TCL_OK) {
Tcl_DecrRefCount(realListPtr);
return status;
}
if (itemPtr == NULL) {
break;
}
status = Tcl_ListObjAppendElement(
interp, realListPtr, itemPtr);
if (status != TCL_OK) {
Tcl_DecrRefCount(realListPtr);
return status;
}
i++;
}
newtailend = newtailindex + tailsize;
for (i = newtailindex; i < newtailend; i++) {
itemPtr = Tcl_NewIntObj(newListRepPtr->values[i]);
Tcl_ListObjAppendElement(interp, realListPtr, itemPtr);
if (status != TCL_OK) {
Tcl_DecrRefCount(realListPtr);
return status;
}
}
ListIntegerDecrRefCount(newListRepPtr);
listPtr->internalRep = realListPtr->internalRep;
listPtr->typePtr = realListPtr->typePtr;
realListPtr->typePtr = NULL;
Tcl_DecrRefCount(realListPtr);
/* this might not always be necessary, but probably the best that
* can be done in this case */
Tcl_InvalidateStringRep(listPtr);
return TCL_OK;
}
}
if (changed) {
Tcl_InvalidateStringRep(listPtr);
}
/* To make the operation transactional, update "used" only after all
* elemnts have been succesfully added.
*/
newListRepPtr->used = newused;
return TCL_OK;
}
static int ListIntegerListObjSetDeep(
TCL_UNUSED(Tcl_Interp *), /* Tcl interpreter. */ \
TCL_UNUSED(Tcl_Obj *), /* Pointer to the list being modified. */ \
TCL_UNUSED(Tcl_Size), /* Number of index args. */ \
TCL_UNUSED(Tcl_Obj *const *), /* Index args. */ \
TCL_UNUSED(Tcl_Obj *),/* Value arg to 'lset' or NULL to 'lpop'. */
Tcl_Obj **resPtrPtr)
{
*resPtrPtr = NULL;
return TCL_ERROR;
}
static int ListIntegerLset(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Size),
TCL_UNUSED(Tcl_Obj *))
{
return TCL_ERROR;
}
static int ErrorMaxElementsExceeded(Tcl_Interp *interp) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%" TCL_T_MODIFIER "d elements) exceeded",
LIST_MAX));
}
return TCL_ERROR;
}
|
1 2 3 4 5 6 | /* * tclTestProcBodyObj.c -- * * Implements the "procbodytest" package, which contains commands to test * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclTestProcBodyObj.c -- * * Implements the "procbodytest" package, which contains commands to test * creation of Tcl procedures whose body argument is a Tcl_Obj of type * "procbody" rather than a string. */ #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | | | | 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 © 1998 Sun Microsystems, Inc.
* Copyright © 2008 George Peter Staplin
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclThread.c --
*
* This file implements Platform independent thread operations. Most of
* the real work is done in the platform dependent files.
*/
#include "tclInt.h"
/*
* There are three classes of synchronization objects: mutexes, thread data
* keys, and condition variables. The following are used to record the memory
* used for these objects so they can be finalized.
*
* These statics are guarded by the mutex in the caller of
* TclRememberThreadData, e.g., TclpThreadDataKeyInit
*/
typedef struct {
int num; /* Number of objects remembered */
int max; /* Max size of the array */
void **list; /* List of pointers */
} SyncObjRecord;
static SyncObjRecord keyRecord = {0, 0, NULL};
static SyncObjRecord mutexRecord = {0, 0, NULL};
static SyncObjRecord condRecord = {0, 0, NULL};
/*
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright © 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. */ #include "tclInt.h" #if TCL_THREADS && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store * the magic number at the end of the requested memory. */ |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
size_t numFree; /* Number of blocks available */
/* All fields below for accounting only */
size_t numRemoves; /* Number of removes from bucket */
size_t numInserts; /* Number of inserts into bucket */
size_t numLocks; /* Number of locks acquired */
| | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
size_t numFree; /* Number of blocks available */
/* All fields below for accounting only */
size_t numRemoves; /* Number of removes from bucket */
size_t numInserts; /* Number of inserts into bucket */
size_t numLocks; /* Number of locks acquired */
size_t totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
* The following structure defines a cache of buckets and objs, of which there
* will be (at most) one per thread. Any changes need to be reflected in the
* struct AllocCache defined in tclInt.h, possibly also in the initialisation
* code in Tcl_CreateInterp().
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
size_t maxBlocks; /* Max blocks before move to share. */
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
size_t maxBlocks; /* Max blocks before move to share. */
size_t numMove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS];
/*
* Static functions defined in this file.
*/
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. * It is done early and protected during the Tcl_InitSubsystems(). * * Results: * None. * * Side effects: * None. * |
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclThreadJoin.c -- * * This file implements a platform independent emulation layer for the * handling of joinable threads. The Windows platform uses this code to * provide the functionality of joining threads. This code is currently * not necessary on Unix. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2000 Scriptics Corporation * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclThreadJoin.c -- * * This file implements a platform independent emulation layer for the * handling of joinable threads. The Windows platform uses this code to * provide the functionality of joining threads. This code is currently * not necessary on Unix. */ #include "tclInt.h" #ifdef _WIN32 /* |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2003-2004 Joe Mistachkin * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclThreadStorage.c -- * * This file implements platform independent thread storage operations to * work around system limits on the number of thread-specific variables. */ #include "tclInt.h" #if TCL_THREADS #include <signal.h> /* * IMPLEMENTATION NOTES: |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
| | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
} tsdGlobal = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct {
void **tablePtr; /* The table of Tcl TSDs. */
sig_atomic_t allocated; /* The size of the table in the current
* thread. */
} TSDTable;
/*
* The actual type of Tcl_ThreadDataKey.
*/
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this should be * tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. | > > > > > > > > > > > > > > > > > < < < < < < | 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 | /* * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this should be * tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. */ #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | | 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 |
/*
* Copyright © 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclTimer.c --
*
* This file provides timer event management facilities for Tcl,
* including the "after" command.
*/
#include "tclInt.h"
/*
* For each timer callback that's pending there is one record of the following
* type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
* together in a list sorted by time (earliest event first).
*/
typedef struct TimerHandler {
Tcl_Time time; /* When timer is to fire. */
Tcl_TimerProc *proc; /* Function to call. */
void *clientData; /* Argument to pass to proc. */
Tcl_TimerToken token; /* Identifies handler so it can be deleted. */
struct TimerHandler *nextPtr;
/* Next event in queue, or NULL for end of
* queue. */
} TimerHandler;
/*
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
* There is one of the following structures for each of the handlers declared
* in a call to Tcl_DoWhenIdle. All of the currently-active handlers are
* linked together into a list.
*/
typedef struct IdleHandler {
Tcl_IdleProc *proc; /* Function to call. */
| | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
* There is one of the following structures for each of the handlers declared
* in a call to Tcl_DoWhenIdle. All of the currently-active handlers are
* linked together into a list.
*/
typedef struct IdleHandler {
Tcl_IdleProc *proc; /* Function to call. */
void *clientData; /* Value to pass to proc. */
int generation; /* Used to distinguish older handlers from
* recently-created ones. */
struct IdleHandler *nextPtr;/* Next in list of active handlers. */
} IdleHandler;
/*
* The timer and idle queues are per-thread because they are associated with
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
*/
Tcl_TimerToken
Tcl_CreateTimerHandler(
int milliseconds, /* How many milliseconds to wait before
* invoking proc. */
Tcl_TimerProc *proc, /* Function to invoke. */
| | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
*/
Tcl_TimerToken
Tcl_CreateTimerHandler(
int milliseconds, /* How many milliseconds to wait before
* invoking proc. */
Tcl_TimerProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary data to pass to proc. */
{
Tcl_Time time;
/*
* Compute when the event should fire.
*/
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
*
*--------------------------------------------------------------
*/
void
Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
| | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 |
*
*--------------------------------------------------------------
*/
void
Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = (IdleHandler *)Tcl_Alloc(sizeof(IdleHandler));
idlePtr->proc = proc;
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
| | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr, *prevPtr;
IdleHandler *nextPtr;
ThreadSpecificData *tsdPtr = InitTimer();
for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 |
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
| | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
command = Tcl_GetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
break;
}
}
if (afterPtr == NULL) {
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
}
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));
| | | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
}
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, (void *)NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr;
TclNewObj(resultListPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
|
| ︙ | ︙ | |||
1145 1146 1147 1148 1149 1150 1151 | * bgerror fails then information about the error is output on stderr. * *---------------------------------------------------------------------- */ static void AfterProc( | | | 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 |
* bgerror fails then information about the error is output on stderr.
*
*----------------------------------------------------------------------
*/
static void
AfterProc(
void *clientData) /* Describes command to execute. */
{
AfterInfo *afterPtr = (AfterInfo *)clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
|
| ︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 | * The memory associated with afterPtr is released. * *---------------------------------------------------------------------- */ static void FreeAfterPtr( | | | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 |
* The memory associated with afterPtr is released.
*
*----------------------------------------------------------------------
*/
static void
FreeAfterPtr(
AfterInfo *afterPtr) /* Command to be deleted. */
{
AfterInfo *prevPtr;
AfterAssocData *assocPtr = afterPtr->assocPtr;
if (assocPtr->firstAfterPtr == afterPtr) {
assocPtr->firstAfterPtr = afterPtr->nextPtr;
} else {
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | * After commands are removed. * *---------------------------------------------------------------------- */ static void AfterCleanupProc( | | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
* After commands are removed.
*
*----------------------------------------------------------------------
*/
static void
AfterCleanupProc(
void *clientData, /* Points to AfterAssocData for the
* interpreter. */
TCL_UNUSED(Tcl_Interp *))
{
AfterAssocData *assocPtr = (AfterAssocData *)clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | # tclTomMath.decls -- # # This file contains the declarations for the functions in 'libtommath' # that are contained within the Tcl library. This file is used to # generate the 'tclTomMathDecls.h' and 'tclStubInit.c' files. # # If you edit this file, advance the revision number (and the epoch # if the new stubs are not backward compatible) in tclTomMathDecls.h # | > > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # Copyright © 2005 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # tclTomMath.decls -- # # This file contains the declarations for the functions in 'libtommath' # that are contained within the Tcl library. This file is used to # generate the 'tclTomMathDecls.h' and 'tclStubInit.c' files. # # If you edit this file, advance the revision number (and the epoch # if the new stubs are not backward compatible) in tclTomMathDecls.h # library tcl # Define the unsupported generic interfaces. interface tclTomMath scspec EXTERN |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
}
declare 15 {
mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c)
}
declare 20 {
| > > > > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
}
declare 15 {
mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
# Removed in 9.0
#declare 17 {
# mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r)
#}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c)
}
declare 20 {
|
| ︙ | ︙ | |||
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 |
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
declare 41 {
mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
}
declare 47 {
size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
declare 63 {
int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
declare 65 {
int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
declare 68 {
void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
declare 71 {
mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
}
declare 72 {
mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
size_t size, mp_endian endian, size_t nails, const mp_int *op)
}
declare 76 {
mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
}
# Added in libtommath 1.2.0
declare 78 {
int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
declare 80 {
int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
# Removed in 9.0
#declare 39 {
# void TclBN_mp_set(mp_int *a, unsigned int b)
#}
# Removed in 9.0
#declare 40 {nostub {is private function in libtommath}} {
# mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b)
#}
declare 41 {
mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
}
# Removed in 9.0
#declare 44 {
# mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
#}
# Removed in 9.0
#declare 45 {
# mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b,
# unsigned long *outlen)
#}
# Removed in 9.0
#declare 46 {
# mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
#}
declare 47 {
size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
# Removed in 9.0
#declare 61 {
# mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i)
#}
# Removed in 9.0
#declare 62 {
# void TclBN_mp_set_ul(mp_int *a, unsigned long i)
#}
declare 63 {
int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
# Removed in 9.0
#declare 64 {
# int TclBN_mp_init_l(mp_int *bignum, long initVal)
#}
declare 65 {
int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
# Removed in 9.0
#declare 67 {
# mp_err TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
#}
# Added in libtommath 1.0.1
declare 68 {
void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
declare 71 {
mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
}
declare 72 {
mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
size_t size, mp_endian endian, size_t nails, const mp_int *op)
}
# Added in libtommath 1.1.0
# No longer in use: replaced by mp_and()
#declare 73 {
# int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
#}
# No longer in use: replaced by mp_or()
#declare 74 {
# int TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
#}
# No longer in use: replaced by mp_xor()
#declare 75 {
# int TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
#}
declare 76 {
mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
declare 77 {
size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size)
}
# Added in libtommath 1.2.0
declare 78 {
int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
# Removed in 9.0
#declare 79 {
# mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r)
#}
declare 80 {
int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
# Local Variables:
# mode: tcl
# End:
|
1 2 3 4 5 6 7 |
#ifndef BN_TCL_H_
#define BN_TCL_H_
#include <stdint.h>
#if defined(TCL_NO_TOMMATH_H)
typedef size_t mp_digit;
typedef int mp_sign;
| > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef BN_TCL_H_
#define BN_TCL_H_
#include <stdint.h>
#if defined(TCL_NO_TOMMATH_H)
typedef size_t mp_digit;
typedef int mp_sign;
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* *---------------------------------------------------------------------- * * tclTomMathDecls.h -- * * This file contains the declarations for the 'libtommath' * functions that are exported by the Tcl library. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* *---------------------------------------------------------------------- * * tclTomMathDecls.h -- * * This file contains the declarations for the 'libtommath' * functions that are exported by the Tcl library. */ #ifndef _TCLTOMMATHDECLS #define _TCLTOMMATHDECLS #include "tcl.h" #include <string.h> |
| ︙ | ︙ |
1 2 3 | #include "tclInt.h" #include "tclTomMath.h" #include "tommath_class.h" | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" #include "tommath_class.h" |
1 2 3 4 5 6 7 | /* *---------------------------------------------------------------------- * * tclTomMathInterface.c -- * * This file contains procedures that are used as a 'glue' layer between * Tcl and libtommath. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 2005 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* *---------------------------------------------------------------------- * * tclTomMathInterface.c -- * * This file contains procedures that are used as a 'glue' layer between * Tcl and libtommath. */ #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclTomMathStubLib.c -- * * Stub object that will be statically linked into extensions that want * to access Tcl. */ #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | | 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 © 1987-1993 The Regents of the University of California.
* Copyright © 1994-1997 Sun Microsystems, Inc.
* Copyright © 1998-2000 Scriptics Corporation.
* Copyright © 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclTrace.c --
*
* This file contains code to handle most trace management.
*/
#include "tclInt.h"
/*
* Structures used to hold information about variable traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
Tcl_Size length; /* Number of non-NUL chars. in command. */
char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
* structure, so that it can be larger than 1
* byte. */
} TraceVarInfo;
typedef struct {
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
Tcl_Size length; /* Number of non-NUL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
| | | | 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 |
typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
Tcl_Size length; /* Number of non-NUL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
Tcl_Size startLevel; /* Used for bookkeeping with step execution
* traces, store the level at which the step
* trace was invoked */
char *startCmd; /* Used for bookkeeping with step execution
* traces, store the command name which
* invoked step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
size_t refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
* structure, so that it can be larger than 1
* byte. */
} TraceCommandInfo;
/*
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
/*
* The following structure holds the client data for string-based
* trace procs
*/
typedef struct {
| | | | | | | 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 |
/*
* The following structure holds the client data for string-based
* trace procs
*/
typedef struct {
void *clientData; /* Client data from Tcl_CreateTrace */
Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */
} StringTraceData;
/*
* Convenience macros for iterating over the list of traces. Note that each of
* these *must* be treated as a command, and *must* have a block following it.
*/
#define FOREACH_VAR_TRACE(interp, name, clientData) \
(clientData) = NULL; \
while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \
0, TraceVarProc, (clientData))) != NULL)
#define FOREACH_COMMAND_TRACE(interp, name, clientData) \
(clientData) = NULL; \
while (((clientData) = Tcl_CommandTraceInfo((interp), (name), 0, \
TraceCommandProc, (clientData))) != NULL)
/*
*----------------------------------------------------------------------
*
* Tcl_TraceObjCmd --
*
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
*
*----------------------------------------------------------------------
*/
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
| | > | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
*
*----------------------------------------------------------------------
*/
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
enum traceOptionsEnum optionIndex,
/* Add, info or remove */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *command;
Tcl_Size length;
static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 | flags |= TCL_TRACE_ENTER_DURING_EXEC; break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 |
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
void *clientData;
/*
* First ensure the name given is valid.
*/
name = TclGetString(objv[3]);
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 |
*
*----------------------------------------------------------------------
*/
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
| | > | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
*
*----------------------------------------------------------------------
*/
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
enum traceOptionsEnum optionIndex,
/* Add, info or remove */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *command;
Tcl_Size length;
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 | break; case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; } } | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
break;
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 | void *clientData; /* * First ensure the name given is valid. */ name = TclGetString(objv[3]); | | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
void *clientData;
/*
* First ensure the name given is valid.
*/
name = TclGetString(objv[3]);
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
*
*----------------------------------------------------------------------
*/
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
| | > | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
*
*----------------------------------------------------------------------
*/
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
enum traceOptionsEnum optionIndex,
/* Add, info or remove */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *command;
Tcl_Size length;
void *clientData;
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 | flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } | | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
flags |= TCL_TRACE_UNSETS;
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
ctvarPtr->traceCmdInfo.length = length;
|
| ︙ | ︙ | |||
977 978 979 980 981 982 983 |
* traced. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
| | | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 |
* traced. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
Tcl_UntraceCommand(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
| | | 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 |
Tcl_UntraceCommand(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *)interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
|
| ︙ | ︙ | |||
1145 1146 1147 1148 1149 1150 1151 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static void TraceCommandProc( | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static void
TraceCommandProc(
void *clientData, /* Information about the command trace. */
Tcl_Interp *interp, /* Interpreter containing command. */
const char *oldName, /* Name of command being changed. */
const char *newName, /* New name of command. Empty string or NULL
* means command is being deleted (renamed to
* ""). */
int flags) /* OR-ed bits giving operation and other
* information. */
|
| ︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 |
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
TCL_UNUSED(Tcl_Size) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
| | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
TCL_UNUSED(Tcl_Size) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
Tcl_Size curLevel;
int traceCode = TCL_OK;
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
const char *command, /* Pointer to beginning of the current command
* string. */
Tcl_Size numChars, /* The number of characters in 'command' which
* are part of the command string. */
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
| | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
const char *command, /* Pointer to beginning of the current command
* string. */
Tcl_Size numChars, /* The number of characters in 'command' which
* are part of the command string. */
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
Tcl_Size curLevel;
int traceCode = TCL_OK;
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
*
*----------------------------------------------------------------------
*/
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
| | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 |
*
*----------------------------------------------------------------------
*/
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
Trace *tracePtr, /* Describes the trace function to call. */
Command *cmdPtr, /* Points to command's Command struct. */
const char *command, /* Points to the first character of the
* command's source before substitutions. */
Tcl_Size numChars, /* The number of characters in the command's
* source. */
Tcl_Size objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
|
| ︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 | * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ static char * TraceVarProc( | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static char *
TraceVarProc(
void *clientData, /* Information about the variable trace. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable or array. */
const char *name2, /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags) /* OR-ed bits giving operation and other
* information. */
{
|
| ︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 |
}
Tcl_Free(info);
}
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
| | | | | | 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 |
}
Tcl_Free(info);
}
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Size level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo));
info->proc = proc;
info->delProc = delProc;
info->clientData = clientData;
return Tcl_CreateObjTrace2(interp, level, flags,
(proc ? traceWrapperProc : NULL),
info, traceWrapperDelProc);
}
Tcl_Trace
Tcl_CreateObjTrace2(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Size level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc2 *proc, /* Trace callback */
void *clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
Trace *tracePtr;
Interp *iPtr = (Interp *) interp;
/*
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 |
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
| | | | 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
*
*----------------------------------------------------------------------
*/
Tcl_Trace
Tcl_CreateTrace(
Tcl_Interp *interp, /* Interpreter in which to create trace. */
Tcl_Size level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
void *clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc,
data, StringTraceDeleteProc);
|
| ︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 |
*
*----------------------------------------------------------------------
*/
int
TclObjCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
| | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
*
*----------------------------------------------------------------------
*/
int
TclObjCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, /* Variable's two-part name. */
int flags, /* Flags passed to trace functions: indicates
* what's happening to variable, plus maybe
|
| ︙ | ︙ | |||
2464 2465 2466 2467 2468 2469 2470 |
return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags,
leaveErrMsg);
}
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
| | | 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags,
leaveErrMsg);
}
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
const char *part1,
const char *part2, /* Variable's two-part name. */
int flags, /* Flags passed to trace functions: indicates
* what's happening to variable, plus maybe
|
| ︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 |
TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result);
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_DiscardInterpState(state);
} else {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
}
| | | 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 |
TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result);
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_DiscardInterpState(state);
} else {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
}
DisposeTraceResult(disposeFlags, result);
} else if (state) {
if (code == TCL_OK) {
code = Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
} else {
Tcl_DiscardInterpState(state);
}
}
|
| ︙ | ︙ | |||
2772 2773 2774 2775 2776 2777 2778 |
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function associated with trace. */
| | | 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 |
* trace applies to scalar variable or array
* as-a-whole. */
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function associated with trace. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
int flagMask, allFlags = 0;
|
| ︙ | ︙ | |||
2975 2976 2977 2978 2979 2980 2981 |
* as-a-whole. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
| | | 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 |
* as-a-whole. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
void *clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclUniData.c -- * * Declarations of Unicode character information tables. This file is * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. | > > > > > > > > > > > > > > < < < | 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 | /* * Copyright © 1998 Scriptics Corporation. * All rights reserved. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUniData.c -- * * Declarations of Unicode character information tables. This file is * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. */ /* * A 16-bit Unicode character is split into two parts in order to index * into the following tables. The lower OFFSET_BITS comprise an offset * into a page of characters. The upper bits comprise the page number. */ |
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9888, 1344, 1344, 9920, 3296, 9952, 9984, 10016,
1344, 1344, 10048, 10080, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 10112, 10144, 1344, 10176, 1344, 10208, 10240, 10272,
10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496,
10528, 4736, 10560, 10592
| < | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9888, 1344, 1344, 9920, 3296, 9952, 9984, 10016,
1344, 1344, 10048, 10080, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 10112, 10144, 1344, 10176, 1344, 10208, 10240, 10272,
10304, 10336, 10368, 1344, 1344, 1344, 10400, 10432, 64, 10464, 10496,
10528, 4736, 10560, 10592
,10624, 10656, 10688, 3296, 1344, 1344, 1344, 10720, 10752, 10784,
10816, 10848, 10880, 10912, 8032, 10944, 3296, 3296, 3296, 3296, 9216,
1344, 10976, 11008, 1344, 11040, 11072, 11104, 11136, 1344, 11168,
3296, 11200, 11232, 11264, 1344, 11296, 11328, 11360, 11392, 1344,
11424, 1344, 11456, 11488, 11520, 1344, 11552, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7776, 4704, 11584, 11616, 11648, 3296,
3296, 11680, 11712, 11744, 11776, 4736, 11808, 3296, 11840, 11872,
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15968
| < | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15968
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
*/
|
| ︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 94, 94, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15,
0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0
| < | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 94, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 94, 94, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15,
0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7, 7, 7, 7, 14, 14, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14, 0, 0
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
|
| ︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 |
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15
| < | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 |
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
* Bits 0-4 Character category: see the constants listed below.
|
| ︙ | ︙ | |||
1729 1730 1731 1732 1733 1734 1735 |
2762882, -2759615, -2751679, -2760383, -2760127, -2768575, 1859714,
-9044927, -10823615, -12158, -10830783, -10833599, -10832575,
-10830015, -10817983, -10824127, -10818751, 237633, -12223, -10830527,
-9058239, -10839743, -10895551, 237698, 9949314, 18, 17, 10305,
10370, 10049, 10114, 8769, 8834
};
| < | < < < | 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 |
2762882, -2759615, -2751679, -2760383, -2760127, -2768575, 1859714,
-9044927, -10823615, -12158, -10830783, -10833599, -10832575,
-10830015, -10817983, -10824127, -10818751, 237633, -12223, -10830527,
-9058239, -10839743, -10895551, 237698, 9949314, 18, 17, 10305,
10370, 10049, 10114, 8769, 8834
};
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
enum {
|
| ︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ | < | < < < | 1791 1792 1793 1794 1795 1796 1797 1798 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. */ #include "tclInt.h" /* * Include the static character classification tables and macros. */ #include "tclUniData.c" |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | * * Given a pointer to a two-byte prefix of a well-formed UTF-8 byte * sequence (a lead byte followed by a trail byte) this routine * examines those two bytes to determine whether the sequence is * invalid in UTF-8. This might be because it is an overlong * encoding, or because it encodes something out of the proper range. * | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | * * Given a pointer to a two-byte prefix of a well-formed UTF-8 byte * sequence (a lead byte followed by a trail byte) this routine * examines those two bytes to determine whether the sequence is * invalid in UTF-8. This might be because it is an overlong * encoding, or because it encodes something out of the proper range. * * Given a pointer to the bytes \xF8 or \xFC, this routine will * try to read beyond the end of the "bounds" table. Callers must * prevent this. * * Given a pointer to something else (an ASCII byte, a trail byte, * or another byte that can never begin a valid byte sequence such * as \xF5) this routine returns false. That makes the routine poorly * named, as it does not detect and report all invalid sequences. |
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
};
static int
Invalid(
| | > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
};
static int
Invalid(
const char *src) /* Points to lead byte of a UTF-8 byte
* sequence. */
{
unsigned char byte = UCHAR(*src);
int index;
if ((byte & 0xC3) == 0xC0) {
/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
index = (byte - 0xC0) >> 1;
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
if (ch >= 0) {
if (ch <= 0x7FF) {
buf[1] = (char) (0x80 | (0x3F & ch));
buf[0] = (char) (0xC0 | (ch >> 6));
return 2;
}
if (ch <= 0xFFFF) {
| > | | > | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
if (ch >= 0) {
if (ch <= 0x7FF) {
buf[1] = (char) (0x80 | (0x3F & ch));
buf[0] = (char) (0xC0 | (ch >> 6));
return 2;
}
if (ch <= 0xFFFF) {
if (
(flags & TCL_COMBINE) &&
((ch & 0xF800) == 0xD800)) {
if (ch & 0x0400) {
/* Low surrogate */
if ( (0x80 == (0xC0 & buf[0]))
&& (0 == (0xCF & buf[1]))) {
/* Previous Tcl_UniChar was a high surrogate, so combine */
buf[2] = (char) (0x80 | (0x3F & ch));
buf[1] |= (char) (0x80 | (0x0F & (ch >> 6)));
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
} else if (byte < 0xF5) {
| > | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
} else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80)
&& ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
return 4;
|
| ︙ | ︙ | |||
517 518 519 520 521 522 523 |
*chPtr = byte;
return 1;
}
Tcl_Size
Tcl_UtfToChar16(
| | | | > | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
*chPtr = byte;
return 1;
}
Tcl_Size
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
unsigned short *chPtr) /* Filled with the Tcl_UniChar represented by
* the UTF-8 string. This could be a surrogate
* too. */
{
unsigned short byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 | * None. * *--------------------------------------------------------------------------- */ Tcl_Size Tcl_NumUtfChars( | | | | | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Size
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
Tcl_Size length) /* The length of the string in bytes, or
* negative value for strlen(src). */
{
Tcl_UniChar ch = 0;
Tcl_Size i = 0;
if (length < 0) {
/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
while (*src != '\0') {
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
}
}
return i;
}
Tcl_Size
TclNumUtfChars(
| | | | | 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 |
}
}
return i;
}
Tcl_Size
TclNumUtfChars(
const char *src, /* The UTF-8 string to measure. */
Tcl_Size length) /* The length of the string in bytes, or
* negative for strlen(src). */
{
unsigned short ch = 0;
Tcl_Size i = 0;
if (length < 0) {
/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
while (*src != '\0') {
|
| ︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 | * None. * *--------------------------------------------------------------------------- */ int Tcl_UniCharAtIndex( | | | | | | | | | | 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 |
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
Tcl_Size index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int i = 0;
if (index < 0) {
return -1;
}
while (index--) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
TclUtfToUniChar(src, &i);
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in the
* UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfAtIndex(
const char *src, /* The UTF-8 string. */
Tcl_Size index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
while (index-- > 0) {
src += TclUtfToUniChar(src, &ch);
}
return src;
}
const char *
TclUtfAtIndex(
const char *src, /* The UTF-8 string. */
Tcl_Size index) /* The position of the desired character. */
{
unsigned short ch = 0;
Tcl_Size len = 0;
if (index > 0) {
while (index--) {
src += (len = Tcl_UtfToChar16(src, &ch));
|
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 |
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(
const void *csPtr, /* UTF string to compare to ct. */
const void *ctPtr, /* UTF string cs is compared to. */
| | | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(
const void *csPtr, /* UTF string to compare to ct. */
const void *ctPtr, /* UTF string cs is compared to. */
size_t numBytes) /* Number of *bytes* to compare. */
{
const char *cs = (const char *)csPtr;
const char *ct = (const char *)ctPtr;
/*
* We can't simply call 'memcmp(cs, ct, numBytes);' because we need to
* check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes
* fine in the strcmp manner.
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcmp -- * | | | | | | | | | | | | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfNcmp --
*
* Compare at most numChars chars (not bytes) of string cs to string ct.
* Both cs and ct are assumed to be at least numChars chars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclUtfNcmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
size_t numChars) /* Number of UTF-16 chars to compare. */
{
unsigned short ch1 = 0, ch2 = 0;
/*
* Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
* pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
* (the byte 0x01.)
*/
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes. This should be called
* only when both strings are of at least n UTF-16 chars long (no
* need for \0 check)
*/
cs += Tcl_UtfToChar16(cs, &ch1);
ct += Tcl_UtfToChar16(ct, &ch2);
if (ch1 != ch2) {
/* Surrogates always report higher than non-surrogates */
if ((ch1 & 0xFC00) == 0xD800) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
return (ch1 - ch2);
}
}
return 0;
}
int
Tcl_UtfNcmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
size_t numChars) /* Number of chars to compare. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
/*
* Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
* pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
* (the byte 0x01.)
|
| ︙ | ︙ | |||
1602 1603 1604 1605 1606 1607 1608 | } /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * | | | | | | | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfNcasecmp --
*
* Compare at most numChars chars (not bytes) of string cs to string ct
* case insensitive. Both cs and ct are assumed to be at least numChars
* UTF-16 chars long.
*
* Results:
* Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclUtfNcasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
size_t numChars) /* Number of UTF-16 chars to compare. */
{
unsigned short ch1 = 0, ch2 = 0;
while (numChars-- > 0) {
/*
* n must be interpreted as UTF-16 chars, not bytes.
* This should be called only when both strings are of
* at least n UTF-16 chars long (no need for \0 check)
*/
cs += Tcl_UtfToChar16(cs, &ch1);
ct += Tcl_UtfToChar16(ct, &ch2);
if (ch1 != ch2) {
/* Surrogates always report higher than non-surrogates */
if ((ch1 & 0xFC00) == 0xD800) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
}
ch1 = Tcl_UniCharToLower(ch1);
ch2 = Tcl_UniCharToLower(ch2);
if (ch1 != ch2) {
return (ch1 - ch2);
}
}
}
return 0;
}
int
Tcl_UtfNcasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
size_t numChars) /* Number of chars to compare. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes.
* This should be called only when both strings are of
|
| ︙ | ︙ | |||
1903 1904 1905 1906 1907 1908 1909 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_UniCharLen( | | | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_UniCharLen(
const int *uniStr) /* Unicode string to find length of. */
{
Tcl_Size len = 0;
while (*uniStr != '\0') {
len++;
uniStr++;
}
|
| ︙ | ︙ | |||
1935 1936 1937 1938 1939 1940 1941 |
*----------------------------------------------------------------------
*/
int
TclUniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 |
*----------------------------------------------------------------------
*/
int
TclUniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
size_t numChars) /* Number of chars to compare. */
{
#if defined(WORDS_BIGENDIAN)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 | } /* *---------------------------------------------------------------------- * * TclUniCharNcasecmp -- * | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* TclUniCharNcasecmp --
*
* Compare at most numChars chars (not bytes) of string ucs to string uct
* case insensitive. Both ucs and uct are assumed to be at least numChars
* chars long.
*
* Results:
* Return <0 if ucs < uct, 0 if ucs == uct, or >0 if ucs > uct.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclUniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
size_t numChars) /* Number of chars to compare. */
{
for ( ; numChars != 0; numChars--, ucs++, uct++) {
if (*ucs != *uct) {
Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1987-1993 The Regents of the University of California. * Copyright © 1994-1998 Sun Microsystems, Inc. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUtil.c -- * * This file contains utility functions that are used by many Tcl * commands. */ #include <assert.h> #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" #include "tclTomMath.h" #include <math.h> |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
* for it. This is a caching internalrep, keeping the result of a parse
* around. This type is only created from a pre-existing string, so an
* updateStringProc will never be called and need not exist. The type
* is unregistered, so has no need of a setFromAnyProc either.
*/
static const Tcl_ObjType endOffsetType = {
| | | | | | < < | < < < < < | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
* for it. This is a caching internalrep, keeping the result of a parse
* around. This type is only created from a pre-existing string, so an
* updateStringProc will never be called and need not exist. The type
* is unregistered, so has no need of a setFromAnyProc either.
*/
static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
0
};
/*
* * 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
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
src++;
count--;
}
}
*dst = 0;
return newCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitList --
*
* Splits a list up into its constituent fields.
| > > > > > > > > > > > > | 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 |
src++;
count--;
}
}
*dst = 0;
return newCount;
}
int
TclLengthOne(
TCL_UNUSED(Tcl_Interp *) /* Used to report errors if not NULL. */
,TCL_UNUSED(Tcl_Obj *) /* List object whose #elements to return. */
,Tcl_Size *lenPtr) /* The resulting length is stored here. */
{
*lenPtr = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SplitList --
*
* Splits a list up into its constituent fields.
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ScanElement( | | | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
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. */
Tcl_Size extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
| | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
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. */
Tcl_Size extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
Tcl_Size 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 */
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 |
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
}
while (length) {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
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 '}' => '\}' */
if (nestingLevel-- < 1) {
/*
* 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 */
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 == TCL_INDEX_NONE) && (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 == TCL_INDEX_NONE) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
default:
if (TclIsSpaceProcM(*p)) {
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif
}
break;
}
}
length -= (length > 0);
p++;
}
endOfString:
if (nestingLevel > 0) {
/*
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertElement( | | | | | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_ConvertElement(
const char *src, /* Source information for list element. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 | * None. * *---------------------------------------------------------------------- */ Tcl_Size Tcl_ConvertCountedElement( | | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
Tcl_Size numBytes = TclConvertElement(src, length, dst, flags);
dst[numBytes] = '\0';
return numBytes;
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclConvertElement( | | | > | 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 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclConvertElement(
const char *src, /* Source information for list element. */
Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int 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 == TCL_INDEX_NONE)) {
p[0] = '{';
p[1] = '}';
return 2;
}
/*
* Escape leading hash as needed and requested.
|
| ︙ | ︙ | |||
1563 1564 1565 1566 1567 1568 1569 | * None. * *---------------------------------------------------------------------- */ char * Tcl_Merge( | | | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
* None.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Merge(
Tcl_Size argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Tcl_Size i;
size_t bytesNeeded = 0;
char *result, *dst;
|
| ︙ | ︙ | |||
1640 1641 1642 1643 1644 1645 1646 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimRight( | | | | | | | | | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclTrimRight(
const char *bytes, /* String to be trimmed... */
Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
Tcl_Size numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrimLeft( | | | | | | | | | | 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
Tcl_Size numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
|
| ︙ | ︙ | |||
1793 1794 1795 1796 1797 1798 1799 | * None. * *---------------------------------------------------------------------- */ Tcl_Size TclTrim( | | | | | | | | | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclTrim(
const char *bytes, /* String to be trimmed... */
Tcl_Size numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
Tcl_Size numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
Tcl_Size *trimRightPtr) /* Offset from the end of the string. */
{
Tcl_Size trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
|
| ︙ | ︙ | |||
1855 1856 1857 1858 1859 1860 1861 | */ /* The whitespace characters trimmed during [concat] operations */ #define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( | | | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 |
*/
/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1)
char *
Tcl_Concat(
Tcl_Size argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
Tcl_Size i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
|
| ︙ | ︙ | |||
1973 1974 1975 1976 1977 1978 1979 |
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
| | | | | | | > > > > | | | 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 |
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr)
|| TclObjectHasInterface(objPtr,list,index)) {
continue;
}
(void)Tcl_GetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
}
if (i == objc) {
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
if (!TclListObjIsCanonical(objPtr)
&& !TclObjectHasInterface(objPtr, list, index)) {
continue;
}
if (resPtr) {
Tcl_Obj *elemPtr = NULL;
Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr);
if (elemPtr == NULL) {
continue;
}
if (TclGetString(elemPtr)[0] == '#' || TCL_OK
!= Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
/* Abandon ship! */
Tcl_DecrRefCount(resPtr);
Tcl_BounceRefCount(elemPtr); // could be an abstract list element
goto slow;
}
Tcl_BounceRefCount(elemPtr); // could be an an abstract list element
} else {
resPtr = TclDuplicatePureObj(
NULL, objPtr, tclListTypePtr);
if (!resPtr) {
return NULL;
}
}
}
if (!resPtr) {
TclNewObj(resPtr);
}
return resPtr;
}
slow:
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
*
* First try to preallocate the size required.
*/
for (i = 0; i < objc; i++) {
element = Tcl_GetStringFromObj(objv[i], &elemLength);
if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) {
break; /* Overflow. Do not preallocate. See comment below. */
}
bytesNeeded += elemLength;
}
/*
* 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);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
Tcl_Size triml, trimr;
element = Tcl_GetStringFromObj(objv[i], &elemLength);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
elemLength -= triml + trimr;
|
| ︙ | ︙ | |||
2333 2334 2335 2336 2337 2338 2339 |
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
| | | | 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 |
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
Tcl_Size strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
Tcl_Size ptnLen, /* Length of Pattern */
TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 |
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
Tcl_Size length;
| | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 |
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
Tcl_Size length;
const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
TclDStringAppendDString(
Tcl_DString *dsPtr,
|
| ︙ | ︙ | |||
2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 |
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
| > | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 |
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
// empty body
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
| | | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
Tcl_Size length) /* New length for dynamic string. */
{
Tcl_Size newsize;
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
|
| ︙ | ︙ | |||
3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 |
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
| > | 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 |
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
// empty body
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
|
| ︙ | ︙ | |||
3294 3295 3296 3297 3298 3299 3300 |
*----------------------------------------------------------------------
*/
Tcl_Size
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
| | | 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 |
*----------------------------------------------------------------------
*/
Tcl_Size
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
Tcl_WideInt n) /* The integer to format. */
{
Tcl_WideUInt intVal;
int i = 0, numFormatted, j;
static const char digits[] = "0123456789";
/*
* Generate the characters of the result backwards in the buffer.
|
| ︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 | * The type of *objPtr may change. * *---------------------------------------------------------------------- */ static int GetWideForIndex( | | | | | 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
* The type of *objPtr may change.
*
*----------------------------------------------------------------------
*/
static int
GetWideForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to the value to be parsed */
Tcl_WideInt endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
void *cd;
|
| ︙ | ︙ | |||
3405 3406 3407 3408 3409 3410 3411 | * integer([+-]integer)? or end([+-]integer)?. * * If the computed index lies within the valid range of Tcl indices * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the | | | 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 | * integer([+-]integer)? or end([+-]integer)?. * * If the computed index lies within the valid range of Tcl indices * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * * Callers should pass reasonable values for endValue - one in the * valid index range or TCL_INDEX_NONE (-1), for example for an empty * list. * * Results: * TCL_OK * * The index is stored at the address given by by 'indexPtr'. * |
| ︙ | ︙ | |||
3476 3477 3478 3479 3480 3481 3482 |
* WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
* WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
* -$n: Index "end-[expr {$n-1}]"
* -2: Index "end-1"
* -1: Index "end"
* 0: Index "0"
* WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for
| | | 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 |
* WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
* WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
* -$n: Index "end-[expr {$n-1}]"
* -2: Index "end-1"
* -1: Index "end"
* 0: Index "0"
* WIDE_MAX-1: Index "end+n", for any n > 1. Distinguish from end+1 for
* commands like lset.
* WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
|
| ︙ | ︙ | |||
3504 3505 3506 3507 3508 3509 3510 |
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
| | < < < < | | > | | | 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 |
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
int t1 = 0, t2 = 0;
/* Value doesn't start with "e" */
/*
* So that lists of index values can be reliably distinguished from
* any single index value, the valid index syntax does not include
* any value that is a list of more than one element.
*/
/*
* Quick scan to see if multi-value list is even possible.
* This relies on TclGetString() returning a NUL-terminated string.
*/
if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == TclListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL,
TCL_INDEX_NONE, &opPtr, TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
|
| ︙ | ︙ | |||
3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 |
goto parseError;
}
if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
/* Doesn't start with "end" */
goto parseError;
}
if (length > 4) {
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
| > | 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 |
goto parseError;
}
if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
/* Doesn't start with "end" */
goto parseError;
}
if (length > 4) {
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
|
| ︙ | ︙ | |||
3733 3734 3735 3736 3737 3738 3739 |
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
* IMPORTANT: function only encodes indices in the range that fits within
* an "int" type. Do NOT change this as the byte code compiler and engine
* which call this function cannot handle wider index types. Indices
* outside the range will result in the function returning an error.
*
* Parse objPtr to determine if it is an index value. Two cases
* are possible. The value objPtr might be parsed as an absolute
* index value in the Tcl_Size range. Note that this includes
* index values that are integers as presented and it includes index
* arithmetic expressions.
*
* The largest string supported in Tcl 8 has byte length TCL_SIZE_MAX.
* This means the largest supported character length is also TCL_SIZE_MAX,
* and the index of the last character in a string of length TCL_SIZE_MAX
* is TCL_SIZE_MAX-1. Thus the absolute index values that can be
* directly meaningful as an index into either a list or a string are
* integer values in the range 0 to TCL_SIZE_MAX - 1.
*
* This function however can only handle integer indices in the range
* 0 : INT_MAX-1.
*
* Any absolute index value parsed outside that range is encoded
* using the before and after values passed in by the
* caller as the encoding to use for indices that are either
* less than or greater than the usable index range. TCL_INDEX_NONE
* is available as a good choice for most callers to use for
* after. Likewise, the value TCL_INDEX_NONE is good for
* most callers to use for before. Other values are possible
* when the caller knows it is helpful in producing its own behavior
* for indices before and after the indexed item.
*
* A token can also be parsed as an end-relative index expression.
* All end-relative expressions that indicate an index larger
* than end (end+2, end--5) point beyond the end of the indexed
* collection, and can be encoded as after. The end-relative
* expressions that indicate an index less than or equal to end
* are encoded relative to the value TCL_INDEX_END (-2). The
* index "end" is encoded as -2, down to the index "end-0x7FFFFFFE"
* which is encoded as INT_MIN. Since the largest index into a
* string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of
* "end-0x7FFFFFFE" for that largest string would be 0. Thus,
* if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
* they can be encoded with the before value.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed or the
* index does not fit in an int type.
*
* Side effects:
* When TCL_OK is returned, the encoded index value is written
* to *indexPtr.
*
*----------------------------------------------------------------------
*/
int
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
int before, /* Value to return for index before beginning */
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
const Tcl_WideInt ENDVALUE = 2 * (Tcl_WideInt) INT_MAX;
assert(ENDVALUE < WIDE_MAX);
if (TCL_OK != GetWideForIndex(interp, objPtr, ENDVALUE, &wide)) {
|
| ︙ | ︙ | |||
3913 3914 3915 3916 3917 3918 3919 |
}
}
*indexPtr = idx;
return TCL_OK;
rangeerror:
if (interp) {
| | > | > | 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 |
}
}
*indexPtr = idx;
return TCL_OK;
rangeerror:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("index \"%s\" out of range"
, TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE"
, (char *)NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3936 3937 3938 3939 3940 3941 3942 | * The decoded index value. * *---------------------------------------------------------------------- */ Tcl_Size TclIndexDecode( | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 |
* The decoded index value.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclIndexDecode(
int encoded, /* Value to decode */
Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
{
if (encoded > TCL_INDEX_END) {
return encoded;
}
endValue += encoded - TCL_INDEX_END;
if (endValue >= 0) {
return endValue;
}
return TCL_INDEX_NONE;
}
int TclIndexIsFromEnd(Tcl_Size index) {
return index <= 0;
}
/*
*----------------------------------------------------------------------
*
* TclIndexLast --
*
* Determine the last index for an array of length "length", where -1 means N is
* not bounded.
*
*----------------------------------------------------------------------
*/
Tcl_Size
TclIndexLast (Tcl_Size length) {
return Tcl_LengthIsFinite(length) ? length - 1 : TCL_INDEX_NONE;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LengthIsFinite --
*
* True if length is Finite.
*
*----------------------------------------------------------------------
*/
int
Tcl_LengthIsFinite(Tcl_Size length) {
return length != TCL_LENGTH_NONE;
}
/*
*------------------------------------------------------------------------
*
* TclIndexInvalidError --
*
* Generates an error message including the invalid index.
*
* Results:
* Always return TCL_ERROR.
*
* Side effects:
* If interp is not-NULL, an error message is stored in it.
*
*------------------------------------------------------------------------
*/
int
TclIndexInvalidError (
Tcl_Interp *interp, /* May be NULL */
const char *idxType, /* The descriptive string for idx. Defaults to "index" */
Tcl_Size idx) /* Invalid index value */
{
if (interp) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Invalid %s value %" TCL_SIZE_MODIFIER "d.",
idxType ? idxType : "index",
idx));
}
return TCL_ERROR; /* Always */
}
/*
*------------------------------------------------------------------------
*
* TclCommandWordLimitErrpr --
*
* Generates an error message limit on number of command words exceeded.
*
* Results:
* Always return TCL_ERROR.
*
* Side effects:
* If interp is not-NULL, an error message is stored in it.
*
*------------------------------------------------------------------------
*/
int
TclCommandWordLimitError(
Tcl_Interp *interp, /* May be NULL */
Tcl_Size count) /* If <= 0, "unknown" */
{
if (interp) {
if (count > 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Number of words (%" TCL_SIZE_MODIFIER
"d) in command exceeds limit %" TCL_SIZE_MODIFIER "d.",
count, (Tcl_Size)INT_MAX));
|
| ︙ | ︙ | |||
4033 4034 4035 4036 4037 4038 4039 |
*----------------------------------------------------------------------
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
| | | | | 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 |
*----------------------------------------------------------------------
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
|
| ︙ | ︙ | |||
4235 4236 4237 4238 4239 4240 4241 |
/*
* If no thread has set the shared value, call the initializer.
*/
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
| | | 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 |
/*
* If no thread has set the shared value, call the initializer.
*/
Tcl_MutexLock(&pgvPtr->mutex);
if ((NULL == pgvPtr->value) && (pgvPtr->proc)) {
pgvPtr->epoch++;
pgvPtr->proc(&pgvPtr->value, &pgvPtr->numBytes, &pgvPtr->encoding);
if (pgvPtr->value == NULL) {
Tcl_Panic("PGV Initializer did not initialize");
}
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
/*
|
| ︙ | ︙ |
1 | /* | < < < < < < < < > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright © 1987-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2007 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclVar.c -- * * This file contains routines that implement Tcl variables (both scalars * and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. */ #include "tclInt.h" #include "tclOOInt.h" /* * Prototypes for the variable hash key methods. */ |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
* twoPtrValue.ptr2: pointer to the element name string (owned by this
* Tcl_Obj), or NULL if it is a scalar variable
*/
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
| < > | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
* twoPtrValue.ptr2: pointer to the element name string (owned by this
* Tcl_Obj), or NULL if it is a scalar variable
*/
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
0
};
#define LocalSetInternalRep(objPtr, index, namePtr) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr = (namePtr); \
if (ptr) {Tcl_IncrRefCount(ptr);} \
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL,
| < > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL,
0
};
#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr1 = (arrayPtr); \
Tcl_Obj *ptr2 = (elem); \
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
static int
NotArrayError(
Tcl_Interp *interp,
Tcl_Obj *name)
{
const char *nameStr = TclGetString(name);
| | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
static int
NotArrayError(
Tcl_Interp *interp,
Tcl_Obj *name)
{
const char *nameStr = TclGetString(name);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" isn't an array", nameStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (char *)NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
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. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
| | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
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. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
Tcl_Size localIndex;
Tcl_Obj *namePtr, *arrayPtr, *elem;
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
Tcl_Size len;
| | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
Tcl_Size len;
const char *part1 = Tcl_GetStringFromObj(part1Ptr, &len);
if ((len > 1) && (part1[len - 1] == ')')) {
const char *part2 = strchr(part1, '(');
if (part2) {
if (part2Ptr != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
| | | | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
int isNew ,result;
Tcl_Size i ,varLen;
const char *varName = Tcl_GetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */
*indexPtr = -3;
if (flags & TCL_GLOBAL_ONLY) {
cxtNsPtr = iPtr->globalNsPtr;
|
| ︙ | ︙ | |||
979 980 981 982 983 984 985 |
const char *localNameStr;
Tcl_Size localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
| | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 |
const char *localNameStr;
Tcl_Size localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
localNameStr = Tcl_GetStringFromObj(objPtr, &localLen);
if ((varLen == localLen) && (varName[0] == localNameStr[0])
&& !memcmp(varName, localNameStr, varLen)) {
*indexPtr = i;
return (Var *) &varFramePtr->compiledLocals[i];
}
}
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 | * TclLookupArrayElement -- * * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | * TclLookupArrayElement -- * * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: * The return value is a pointer to the variable structure, or NULL if * the variable couldn't be found. * * If arrayPtr points to a variable that isn't an array and createPart1 * is 1, the corresponding variable will be converted to an array. * Otherwise, NULL is returned and an error message is left in the * interp's result if TCL_LEAVE_ERR_MSG is set in flags. * |
| ︙ | ︙ | |||
1486 1487 1488 1489 1490 1491 1492 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
| | | 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValueObj == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varValueObj);
return TCL_OK;
} else if (objc == 3) {
varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
}
/*
* It's an error to try to set a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
| | | | 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 |
}
/*
* It's an error to try to set a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST, index);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL);
}
goto earlyError;
}
/*
* It's an error to try to set an array variable itself.
*/
if (TclIsVarArray(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISARRAY, index);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL);
}
goto earlyError;
}
TclVarFindHiddenArray(varPtr, arrayPtr);
|
| ︙ | ︙ | |||
2236 2237 2238 2239 2240 2241 2242 |
Tcl_Obj *varValuePtr;
/*
* It's an error to try to increment a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
| | | 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 |
Tcl_Obj *varValuePtr;
/*
* It's an error to try to increment a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST, index);
Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL);
}
return NULL;
}
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
|
| ︙ | ︙ | |||
2473 2474 2475 2476 2477 2478 2479 |
Var *initialArrayPtr = arrayPtr;
/*
* It's an error to try to unset a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
| | | 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 |
Var *initialArrayPtr = arrayPtr;
/*
* It's an error to try to unset a constant.
*/
if (TclIsVarConstant(varPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST, index);
Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL);
}
return TCL_ERROR;
}
/*
* Keep the variable alive until we're done with it. We used to
|
| ︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 |
flags |= VAR_ARRAY_ELEMENT;
} else if (TclIsVarArrayElement(varPtr)) {
part2Ptr = VarHashGetKey(varPtr);
}
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
| | | < | 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
flags |= VAR_ARRAY_ELEMENT;
} else if (TclIsVarArrayElement(varPtr)) {
part2Ptr = VarHashGetKey(varPtr);
}
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT))
| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index);
/*
* The traces that we just called may have triggered a change in
* the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
|
| ︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
if (objc == 2) {
| | | 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
if (objc == 2) {
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
|
| ︙ | ︙ | |||
3131 3132 3133 3134 3135 3136 3137 |
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
| | | 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 |
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
varListObj = TclDuplicatePureObj(interp, objv[1], tclListTypePtr);
if (!varListObj) {
return TCL_ERROR;
}
scriptObj = objv[3];
Tcl_IncrRefCount(scriptObj);
/*
|
| ︙ | ︙ | |||
4030 4031 4032 4033 4034 4035 4036 |
}
/*
* Install the contents of the dictionary or list into the array.
*/
arrayElemObj = objv[2];
| | | 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 |
}
/*
* Install the contents of the dictionary or list into the array.
*/
arrayElemObj = objv[2];
if (TclHasInternalRep(arrayElemObj, tclDictTypePtr) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
Tcl_Size size;
if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
4107 4108 4109 4110 4111 4112 4113 | /* * We needn't worry about traces invalidating arrayPtr: should that be * the case, TclPtrSetVarIdx will return NULL so that we break out of * the loop and return an error. */ | | > | 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 |
/*
* We needn't worry about traces invalidating arrayPtr: should that be
* the case, TclPtrSetVarIdx will return NULL so that we break out of
* the loop and return an error.
*/
copyListObj =
TclDuplicatePureObj(interp, arrayElemObj, tclListTypePtr);
if (!copyListObj) {
return TCL_ERROR;
}
for (i=0 ; i<elemLen ; i+=2) {
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
|
| ︙ | ︙ | |||
4297 4298 4299 4300 4301 4302 4303 |
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
const char *pattern;
| | | 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 |
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
const char *pattern;
int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */
int isArray;
switch (objc) {
case 2:
varNameObj = objv[1];
patternObj = NULL;
break;
|
| ︙ | ︙ | |||
4522 4523 4524 4525 4526 4527 4528 |
* local variable in a procedure. If we allowed this, the local
* variable in the shorter-lived procedure frame could go away leaving
* the namespace var's reference invalid.
*/
if (index < 0) {
if (!(arrayPtr != NULL
| | | | 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 |
* local variable in a procedure. If we allowed this, the local
* variable in the shorter-lived procedure frame could go away leaving
* the namespace var's reference invalid.
*/
if (index < 0) {
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\": can't create namespace "
"variable that refers to procedure variable",
|
| ︙ | ︙ | |||
5606 5607 5608 5609 5610 5611 5612 |
*/
if (elPtr->flags & VAR_TRACED_UNSET) {
Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);
elPtr->flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
| | | 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 |
*/
if (elPtr->flags & VAR_TRACED_UNSET) {
Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);
elPtr->flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
elNamePtr, flags, /* leaveErrMsg */ 0, index);
}
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2016-2017 Sean Woods <yoda@etoyoc.com> * Copyright © 2013-2015 Christian Werner <chw@ch-werner.de> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclZipfs.c -- * * Implementation of the ZIP filesystem used in TIP 430 * Adapted from the implementation for AndroWish. * * This file is distributed in two ways: * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 * projects. * * Helpful docs: |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | #include <dlfcn.h> #endif /* * Macros to report errors only if an interp is present. */ | | | > | | | | | > | | | | | | | | | > > > > | > > > > > > > > > > | < > | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | > > | > | | > | > | > | | > > > > > > | 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 |
#include <dlfcn.h>
#endif
/*
* Macros to report errors only if an interp is present.
*/
#define ZIPFS_ERROR(interp, errstr) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, \
Tcl_NewStringObj(errstr, TCL_AUTO_LENGTH)); \
} \
} while (0)
#define ZIPFS_MEM_ERROR(interp) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_NewStringObj( \
"out of memory", TCL_AUTO_LENGTH)); \
Tcl_SetErrorCode(interp, "TCL", "MALLOC", (char *)NULL); \
} \
} while (0)
#define ZIPFS_POSIX_ERROR(interp, errstr) \
do { \
if (interp) { \
Tcl_SetObjResult(interp, Tcl_ObjPrintf( \
"%s: %s", errstr, Tcl_PosixError(interp))); \
} \
} while (0)
#define ZIPFS_ERROR_CODE(interp, errcode) \
do { \
if (interp) { \
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, \
(char *)NULL); \
} \
} while (0)
#ifdef HAVE_ZLIB
#include "zlib.h"
#include "crypt.h"
#include "zutil.h"
#include "crc32.h"
static const z_crc_t* crc32tab;
/*
* We are compiling as part of the core.
* TIP430 style zipfs prefix
*/
#define ZIPFS_VOLUME "//zipfs:/"
#define ZIPFS_ROOTDIR_DEPTH 3 /* Number of / in root mount */
#define ZIPFS_VOLUME_LEN 9
#define ZIPFS_APP_MOUNT ZIPFS_VOLUME "app"
#define ZIPFS_ZIP_MOUNT ZIPFS_VOLUME "lib/tcl"
#define ZIPFS_FALLBACK_ENCODING "cp437"
/* What's the magic about 64 * 1024 * 1024 ? Is it where ZIP64 is needed? */
#define ZIPFS_MAX_DIR_SIZE (64 * 1024 * 1024)
#define ZIPFS_PASSBUF_SIZE 264
/*
* Various constants and offsets found in ZIP archive files
*/
#define ZIP_SIG_LEN 4
/*
* The ZIP format is based on a number of structures, logically a ZipCentral
* that points to a list of CentralHeaders that in turn point to LocalHeaders
* that point to the data. However, we don't write those structures out
* explicitly because we firstly MUST read them all as little-endian data,
* secondly they're structures that are packed very tightly, and thirdly they
* have multiple blocks of data attached to them, which C supports poorly
* (along with many other languages). So instead we have a collection of
* offsets instead, all of which are relative to the signature field of each
* structure (which is always first).
*
* Local header of ZIP archive member (at very beginning of each member).
*/
#define ZIP_LOCAL_HEADER_SIG 0x04034b50
enum ZipLocalHeaderOffsets {
LOCAL_SIG = 0, // LocalHeader.signature
LOCAL_VERSION = 4, // LocalHeader.version
LOCAL_FLAGS = 6, // LocalHeader.flags
LOCAL_COMPMETH = 8, // LocalHeader.compressionMethod
LOCAL_MTIME = 10, // LocalHeader.modifiedTime
LOCAL_MDATE = 12, // LocalHeader.modifiedDate
LOCAL_CRC32 = 14, // LocalHeader.crc32
LOCAL_COMPLEN = 18, // LocalHeader.compressedLength
LOCAL_UNCOMPLEN = 22, // LocalHeader.uncompressedLength
LOCAL_PATHLEN = 26, // LocalHeader.pathLength
LOCAL_EXTRALEN = 28, // LocalHeader.extraDataLength
LOCAL_HEADER_LEN = 30 // sizeof(LocalHeader)
};
#define ZIP_LOCAL_FLAGS_UTF8 0x0800
/*
* Central header of ZIP archive member at end of ZIP file.
*/
#define ZIP_CENTRAL_HEADER_SIG 0x02014b50
enum ZipCentralHeaderOffsets {
CENTRAL_SIG = 0, // CentralHeader.signature
CENTRAL_VERSIONMADE = 4, // CentralHeader.versionMade
CENTRAL_VERSION = 6, // CentralHeader.version
CENTRAL_FLAGS = 8, // CentralHeader.flags
CENTRAL_COMPMETH = 10, // CentralHeader.compressionMethod
CENTRAL_MTIME = 12, // CentralHeader.modifiedTime
CENTRAL_MDATE = 14, // CentralHeader.modifiedDate
CENTRAL_CRC32 = 16, // CentralHeader.crc32
CENTRAL_COMPLEN = 20, // CentralHeader.compressedLength
CENTRAL_UNCOMPLEN = 24, // CentralHeader.uncompressedLength
CENTRAL_PATHLEN = 28, // CentralHeader.pathLength
CENTRAL_EXTRALEN = 30, // CentralHeader.extraDataLength
CENTRAL_FCOMMENTLEN = 32, // CentralHeader.commentLength
CENTRAL_DISKFILE = 34, // CentralHeader.diskFile
CENTRAL_IATTR = 36, // CentralHeader.interalAttributes
CENTRAL_EATTR = 38, // CentralHeader.externalAttributes
CENTRAL_LOCALHDR = 42, // CentralHeader.localHeader
CENTRAL_HEADER_LEN = 46 // sizeof(CentralHeader)
};
/*
* Central end signature at very end of ZIP file.
*/
#define ZIP_CENTRAL_END_SIG 0x06054b50
enum ZipCentralSignatureOffsets {
CENTRAL_END_SIG = 0, // ZipCentral.endSignature
CENTRAL_DISKNO = 4, // ZipCentral.diskNumber
CENTRAL_DISKDIR = 6, // ZipCentral.diskDirectory
CENTRAL_ENTS = 8, // ZipCentral.diskEntries
CENTRAL_TOTALENTS = 10, // ZipCentral.totalEntries
CENTRAL_DIRSIZE = 12, // ZipCentral.directorySize
CENTRAL_DIRSTART = 16, // ZipCentral.directoryStart
CENTRAL_COMMENTLEN = 20, // ZipCentral.commentLength
CENTRAL_END_LEN = 22 // sizeof(ZipCentral)
};
#define ZIP_MIN_VERSION 20
enum ZipCompressionMethods {
ZIP_COMPMETH_STORED = 0,
ZIP_COMPMETH_DEFLATED = 8
};
#define ZIP_PASSWORD_END_SIG 0x5a5a4b50
enum ZipCryptOffsets {
ZIP_CRYPT_HDR_LEN = 12 // sizeof(ZipCrypt)
};
#define ZIP_MAX_FILE_SIZE INT_MAX
#define DEFAULT_WRITE_MAX_SIZE ZIP_MAX_FILE_SIZE
/*
* The ZIP deflated compression method requires a raw zlib (de)compressor.
* No header required; the ZIP format has its own.
*/
#define ZLIB_MODE_RAW (-15)
/*
* Mutex to protect localtime(3) when no reentrant version available.
*/
#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS
TCL_DECLARE_MUTEX(localtimeMutex)
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
unsigned char *data; /* Memory mapped or malloc'ed file */
size_t length; /* Length of memory mapped file */
void *ptrToFree; /* Non-NULL if malloc'ed file */
size_t numFiles; /* Number of files in archive */
size_t baseOffset; /* Archive start */
size_t passOffset; /* Password start */
size_t directoryOffset; /* Archive directory start */
| | | > > > < < < > > > > > > | 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 |
unsigned char *data; /* Memory mapped or malloc'ed file */
size_t length; /* Length of memory mapped file */
void *ptrToFree; /* Non-NULL if malloc'ed file */
size_t numFiles; /* Number of files in archive */
size_t baseOffset; /* Archive start */
size_t passOffset; /* Password start */
size_t directoryOffset; /* Archive directory start */
size_t directorySize; /* Size of archive directory */
unsigned char passBuf[ZIPFS_PASSBUF_SIZE];
/* Password buffer */
size_t numOpen; /* Number of open files on archive */
struct ZipEntry *entries; /* List of files in archive */
struct ZipEntry *topEnts; /* List of top-level dirs in archive */
char *mountPoint; /* Mount point name */
Tcl_Size mountPointLen; /* Length of mount point name */
#ifdef _WIN32
HANDLE mountHandle; /* Handle used for direct file access. */
#endif /* _WIN32 */
} ZipFile;
/*
* In-core description of file contained in mounted ZIP archive.
*/
typedef struct ZipEntry {
char *name; /* The full pathname of the virtual file */
Tcl_Size nameLen; /* Length of name field. TCL_AUTO_LENGTH if not
* yet computed. */
ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */
size_t offset; /* Data offset into memory mapped ZIP file */
int numBytes; /* Uncompressed size of the virtual file.
* -1 for zip64 */
int numCompressedBytes; /* Compressed size of the virtual file.
* -1 for zip64 */
int compressMethod; /* Compress method */
int isDirectory; /* 0 if file, 1 if directory, -1 if root */
int depth; /* Number of slashes in path. */
int crc32; /* CRC-32 as stored in ZIP */
int timestamp; /* Modification time */
int isEncrypted; /* True if data is encrypted */
int flags;
unsigned char *data; /* File data if written */
struct ZipEntry *next; /* Next file in the same archive */
struct ZipEntry *tnext; /* Next top-level dir in archive */
} ZipEntry;
enum ZipEntryFlags {
ZE_F_CRC_COMPARED = 1, /* If 1, the CRC has been compared. */
ZE_F_CRC_CORRECT = 2, /* Only meaningful if ZE_F_CRC_COMPARED is 1 */
ZE_F_VOLUME = 4 /* Entry corresponds to //zipfs:/ */
};
/*
* File channel for file contained in mounted ZIP archive.
*
* Regarding data buffers:
* For READ-ONLY files that are not encrypted and not compressed (zip STORE
* method), ubuf points directly to the mapped zip file data in memory. No
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
typedef struct ZipChannel {
ZipFile *zipFilePtr; /* The ZIP file holding this channel */
ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
Tcl_Size maxWrite; /* Maximum size for write */
Tcl_Size numBytes; /* Number of bytes of uncompressed data */
Tcl_Size cursor; /* Seek position for next read or write*/
unsigned char *ubuf; /* Pointer to the uncompressed data */
| | | | | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
typedef struct ZipChannel {
ZipFile *zipFilePtr; /* The ZIP file holding this channel */
ZipEntry *zipEntryPtr; /* Pointer back to virtual file */
Tcl_Size maxWrite; /* Maximum size for write */
Tcl_Size numBytes; /* Number of bytes of uncompressed data */
Tcl_Size cursor; /* Seek position for next read or write*/
unsigned char *ubuf; /* Pointer to the uncompressed data */
unsigned char *ubufToFree; /* NULL if ubuf points to memory that does not
* need freeing. Else memory to free (ubuf
* may point *inside* the block) */
Tcl_Size ubufSize; /* Size of allocated ubufToFree */
int isCompressed; /* True if data is compressed */
int isDirectory; /* Set to 1 if directory, or -1 if root */
int isEncrypted; /* True if data is encrypted */
int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/
unsigned long keys[3]; /* Key for decryption */
} ZipChannel;
static inline int
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 | * The "fileHash" component is the process-wide global table of all known ZIP * archive members in all mounted ZIP archives. * * The "zipHash" components is the process wide global table of all mounted * ZIP archive files. */ | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
* The "fileHash" component is the process-wide global table of all known ZIP
* archive members in all mounted ZIP archives.
*
* The "zipHash" components is the process wide global table of all mounted
* ZIP archive files.
*/
static struct ZipFSGlobals {
int initialized; /* True when initialized */
int lock; /* RW lock, see below */
int waiters; /* RW lock, see below */
int wrmax; /* Maximum write size of a file; only written
* to from Tcl code in a trusted interpreter,
* so NOT protected by mutex. */
char *fallbackEntryEncoding;/* The fallback encoding for ZIP entries when
|
| ︙ | ︙ | |||
327 328 329 330 331 332 333 | static int DescribeMounted(Tcl_Interp *interp, const char *mountPoint); static int InitReadableChannel(Tcl_Interp *interp, ZipChannel *info, ZipEntry *z); static int InitWritableChannel(Tcl_Interp *interp, ZipChannel *info, ZipEntry *z, int trunc); static int ListMountPoints(Tcl_Interp *interp); | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 | static int DescribeMounted(Tcl_Interp *interp, const char *mountPoint); static int InitReadableChannel(Tcl_Interp *interp, ZipChannel *info, ZipEntry *z); static int InitWritableChannel(Tcl_Interp *interp, ZipChannel *info, ZipEntry *z, int trunc); static int ListMountPoints(Tcl_Interp *interp); static int ContainsMountPoint(const char *path, Tcl_Size pathLen); static void CleanupMount(ZipFile *zf); static Tcl_Obj * ScriptLibrarySetup(const char *dirName); static void SerializeCentralDirectoryEntry( const unsigned char *start, const unsigned char *end, unsigned char *buf, ZipEntry *z, size_t nameLength); static void SerializeCentralDirectorySuffix( |
| ︙ | ︙ | |||
351 352 353 354 355 356 357 | unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]); static int DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z, unsigned long keys[3], unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]); #if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit(const char *archive); #endif | | < | | | | | < | | > > > | < < < < < < < < < < | < | < | < | < | < | 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 |
unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
static int DecodeCryptHeader(Tcl_Interp *interp, ZipEntry *z,
unsigned long keys[3],
unsigned char cryptHdr[ZIP_CRYPT_HDR_LEN]);
#if !defined(STATIC_BUILD)
static int ZipfsAppHookFindTclInit(const char *archive);
#endif
static Tcl_FSPathInFilesystemProc ZipFSPathInFilesystemProc;
static Tcl_FSFilesystemPathTypeProc ZipFSFilesystemPathTypeProc;
static Tcl_FSFilesystemSeparatorProc ZipFSFilesystemSeparatorProc;
static Tcl_FSStatProc ZipFSStatProc;
static Tcl_FSAccessProc ZipFSAccessProc;
static Tcl_FSOpenFileChannelProc ZipFSOpenFileChannelProc;
static Tcl_FSMatchInDirectoryProc ZipFSMatchInDirectoryProc;
static Tcl_FSListVolumesProc ZipFSListVolumesProc;
static Tcl_FSFileAttrStringsProc ZipFSFileAttrStringsProc;
static Tcl_FSFileAttrsGetProc ZipFSFileAttrsGetProc;
static Tcl_FSFileAttrsSetProc ZipFSFileAttrsSetProc;
static Tcl_FSLoadFileProc2 ZipFSLoadFile;
static void ZipFSMatchMountPoints(Tcl_Obj *result,
Tcl_Obj *normPathPtr, const char *pattern,
Tcl_DString *prefix);
static int ZipMapArchive(Tcl_Interp *interp, ZipFile *zf,
void *handle);
static void ZipfsSetup(void);
static Tcl_DriverClose2Proc ZipChannelClose;
static Tcl_DriverGetHandleProc ZipChannelGetFile;
static Tcl_DriverInputProc ZipChannelRead;
static Tcl_DriverWideSeekProc ZipChannelWideSeek;
static Tcl_DriverWatchProc ZipChannelWatchChannel;
static Tcl_DriverOutputProc ZipChannelWrite;
/*
* Define the ZIP filesystem dispatch table.
*/
static const Tcl_Filesystem zipfsFilesystem = {
"zipfs",
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 461 462 |
NULL, /* Thread action function. */
NULL, /* Truncate function. */
};
/*
*------------------------------------------------------------------------
*
* TclIsZipfsPath --
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | 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 |
NULL, /* Thread action function. */
NULL, /* Truncate function. */
};
/*
*------------------------------------------------------------------------
*
* HasVolumePrefix --
*
* Test to see if the given path is prefixed with our standard volume
* label.
*
* Results:
* A true value if the volume label is a prefix.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static inline int
HasVolumePrefix(
const char *path)
{
TCL_CT_ASSERT(sizeof(ZIPFS_VOLUME) == ZIPFS_VOLUME_LEN + 1);
return !strncmp(ZIPFS_VOLUME, path, ZIPFS_VOLUME_LEN);
}
/*
*------------------------------------------------------------------------
*
* ZipEntryNameLength --
*
* Get the length of the name of a zip entry.
*
* Results:
* The length of the name.
*
* Side effects:
* Computes and caches the length of the name if it has not already been
* determined.
*
*------------------------------------------------------------------------
*/
static inline Tcl_Size
ZipEntryNameLength(
ZipEntry *z)
{
if (z->nameLen < 0) {
z->nameLen = strlen(z->name);
}
return z->nameLen;
}
/*
*------------------------------------------------------------------------
*
* TclIsZipfsPath --
*
* Checks if the passed path has a zipfs volume prefix.
*
* Results:
* 0 if not a zipfs path
* else the length of the zipfs volume prefix
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
int
TclIsZipfsPath(
const char *path)
{
#ifdef _WIN32
return HasVolumePrefix(path) ? ZIPFS_VOLUME_LEN : 0;
#else
int i;
for (i = 0; i < ZIPFS_VOLUME_LEN; ++i) {
if (path[i] != ZIPFS_VOLUME[i]
&& (path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) {
return 0;
}
}
return ZIPFS_VOLUME_LEN;
#endif
}
/*
*-------------------------------------------------------------------------
*
* ZipReadInt, ZipReadShort, ZipWriteInt, ZipWriteShort --
*
* Inline functions to read and write little-endian 16 and 32 bit
* integers from/to buffers representing parts of ZIP archives.
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 |
if (ptr < bufferStart || ptr + 2 > bufferEnd) {
Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p",
bufferStart, bufferEnd, ptr);
}
ptr[0] = value & 0xff;
ptr[1] = (value >> 8) & 0xff;
}
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
if (ptr < bufferStart || ptr + 2 > bufferEnd) {
Tcl_Panic("out of bounds write(2): start=%p, end=%p, ptr=%p",
bufferStart, bufferEnd, ptr);
}
ptr[0] = value & 0xff;
ptr[1] = (value >> 8) & 0xff;
}
/*
*-------------------------------------------------------------------------
*
* ReadLock, WriteLock, Unlock --
*
* POSIX like rwlock functions to support multiple readers and single
* writer on internal structs.
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 | } /* *------------------------------------------------------------------------ * * IsCryptHeaderValid -- * | | | | > | | | | | | 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 |
}
/*
*------------------------------------------------------------------------
*
* IsCryptHeaderValid --
*
* Computes the validity of the encryption header CRC for a ZipEntry.
*
* Results:
* Returns 1 if the header is valid else 0.
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
IsCryptHeaderValid(
ZipEntry *z,
unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN])
{
/*
* There are multiple possibilities. The last one or two bytes of the
* encryption header should match the last one or two bytes of the
* CRC of the file. Or the last byte of the encryption header should
* be the high order byte of the file time. Depending on the archiver
* and version, any of the might be in used. We follow libzip in checking
* only one byte against both the crc and the time. Note that by design
* the check generates high number of false positives in any case.
* Also, in case a check is passed when it should not, the final CRC
* calculation will (should) catch it. Only difference is it will be
* reported as a corruption error instead of incorrect password.
*/
int dosTime = ToDosTime(z->timestamp);
if (cryptHeader[11] == (unsigned char)(dosTime >> 8)) {
/* Infozip style - Tested with test-password.zip */
return 1;
}
/* DOS time did not match, may be CRC does */
if (z->crc32) {
/* Pkware style - Tested with test-password2.zip */
return (cryptHeader[11] == (unsigned char)(z->crc32 >> 24));
}
/* No CRC, no way to verify. Assume valid */
return 1;
}
/*
*------------------------------------------------------------------------
*
* DecodeCryptHeader --
*
* Decodes the crypt header and validates it.
*
* Results:
* TCL_OK on success, TCL_ERROR on failure.
*
* Side effects:
* On success, keys[] are updated. On failure, an error message is
* left in interp if not NULL.
*
*------------------------------------------------------------------------
*/
static int
DecodeCryptHeader(
Tcl_Interp *interp,
ZipEntry *z,
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
if (!IsCryptHeaderValid(z, encheader)) {
ZIPFS_ERROR(interp, "invalid password");
ZIPFS_ERROR_CODE(interp, "PASSWORD");
return TCL_ERROR;
}
return TCL_OK;
}
| | | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
if (!IsCryptHeaderValid(z, encheader)) {
ZIPFS_ERROR(interp, "invalid password");
ZIPFS_ERROR_CODE(interp, "PASSWORD");
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* DecodeZipEntryText --
*
* Given a sequence of bytes from an entry in a ZIP central directory,
* convert that into a Tcl string. This is complicated because we don't
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 | } /* *------------------------------------------------------------------------ * * NormalizeMountPoint -- * | | | | | | | | | | | | | | | | < < | | > | > > > > > > > | | > > > > > > | < < | | | | | | | | < < > | > > | | | < | | 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 |
}
/*
*------------------------------------------------------------------------
*
* NormalizeMountPoint --
*
* Converts the passed path into a normalized zipfs mount point
* of the form //zipfs:/some/path. On Windows any \ path separators
* are converted to /.
*
* Mount points with a volume will raise an error unless the volume is
* zipfs root. Thus D:/foo is not a valid mount point.
*
* Relative paths and absolute paths without a volume are mapped under
* the zipfs root.
*
* The empty string is mapped to the zipfs root.
*
* dsPtr is initialized by the function and must be cleared by caller
* on a successful return.
*
* Results:
* TCL_OK on success with normalized mount path in dsPtr
* TCL_ERROR on fail with error message in interp if not NULL
*
*------------------------------------------------------------------------
*/
static int
NormalizeMountPoint(
Tcl_Interp *interp,
const char *mountPath,
Tcl_DString *dsPtr) /* Must be initialized by caller! */
{
const char *joiner[2];
const char *joinedPath;
Tcl_Obj *unnormalizedObj; /* Before baseline normalization. */
Tcl_Obj *normalizedObj; /* After baseline normalization. */
Tcl_DString dsJoin; /* Buffer. Lifetime for joinedPath. */
/*
* Several things need to happen here:
* - Absolute paths containing volumes (drive letter or UNC) raise error
* except of course if the volume is zipfs root
* - \ -> / and // -> / conversions (except if UNC which is error)
* - . and .. have to be dealt with
*
* The first is explicitly checked, the others are dealt with a
* combination file join and normalize. Easier than doing it ourselves
* and not performance sensitive anyways.
*/
joiner[0] = ZIPFS_VOLUME;
joiner[1] = mountPath;
Tcl_DStringInit(&dsJoin);
joinedPath = Tcl_JoinPath(2, joiner, &dsJoin);
/* Now joinedPath has all \ -> / and // -> / (except UNC) converted. */
if (HasVolumePrefix(joinedPath)) {
unnormalizedObj = Tcl_DStringToObj(&dsJoin);
} else {
if (joinedPath[0] != '/' || joinedPath[1] == '/') {
/* mount path was D:/x, D:x or //unc */
goto invalidMountPath;
}
unnormalizedObj = Tcl_ObjPrintf(ZIPFS_VOLUME "%s", joinedPath + 1);
}
Tcl_DStringFree(&dsJoin);
/*
* Now unnormalizedObj is the name in the volume... but still needs to be
* cleaned up and the result transferred to the caller's buffer.
*/
Tcl_IncrRefCount(unnormalizedObj);
normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj);
if (normalizedObj == NULL) {
Tcl_DecrRefCount(unnormalizedObj);
goto errorReturn;
}
TclDStringAppendObj(dsPtr, normalizedObj);
/*
* Careful! The normalized and unnormalized objects may be the same,
* or the normalized one might be something cached inside Tcl's path
* management guts.
*/
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
Tcl_DecrRefCount(unnormalizedObj);
Tcl_DecrRefCount(normalizedObj);
return TCL_OK;
invalidMountPath:
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid mount path \"%s\"", mountPath));
ZIPFS_ERROR_CODE(interp, "MOUNT_PATH");
}
errorReturn:
Tcl_DStringFree(&dsJoin);
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
*
* MapPathToZipfs --
*
* Maps a path as stored in a zip archive to its normalized location
* under a given zipfs mount point. Relative paths and Unix style
* absolute paths go directly under the mount point. Volume relative
* paths and absolute paths that have a volume (drive or UNC) are
* stripped of the volume before joining the mount point.
*
* Results:
* Pointer to normalized path.
*
* Side effects:
* Stores mapped path in dsPtr.
*
*------------------------------------------------------------------------
*/
static char *
MapPathToZipfs(
Tcl_Interp *interp,
const char *mountPath, /* Must be fully normalized */
const char *path, /* Archive content path to map */
Tcl_DString *dsPtr) /* Must be initialized and cleared
* by caller */
{
const char *joiner[2];
char *joinedPath;
Tcl_Obj *unnormalizedObj;
Tcl_Obj *normalizedObj;
Tcl_DString dsJoin;
assert(TclIsZipfsPath(mountPath));
joiner[0] = mountPath;
joiner[1] = path;
#ifndef _WIN32
/*
* On Unix C:/foo/bat is not treated as absolute by JoinPath so check
* ourself.
*/
if (path[0] && path[1] == ':') {
joiner[1] += 2;
}
#endif
Tcl_DStringInit(&dsJoin);
joinedPath = Tcl_JoinPath(2, joiner, &dsJoin);
if (!HasVolumePrefix(joinedPath)) {
/* path was not relative. Strip off the volume (e.g. UNC) */
Tcl_Size numParts;
const char **partsPtr;
Tcl_SplitPath(path, &numParts, &partsPtr);
Tcl_DStringFree(&dsJoin);
partsPtr[0] = mountPath;
(void) Tcl_JoinPath(numParts, partsPtr, &dsJoin);
Tcl_Free(partsPtr);
}
unnormalizedObj = Tcl_DStringToObj(&dsJoin); /* Also resets dsJoin */
Tcl_IncrRefCount(unnormalizedObj);
normalizedObj = Tcl_FSGetNormalizedPath(interp, unnormalizedObj);
if (normalizedObj == NULL) {
/* Should not happen but continue... */
normalizedObj = unnormalizedObj;
}
Tcl_IncrRefCount(normalizedObj); // BEFORE DecrRefCount on unnormalizedObj
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
TclDStringAppendObj(dsPtr, normalizedObj);
Tcl_DecrRefCount(normalizedObj);
return Tcl_DStringValue(dsPtr);
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 | /* *------------------------------------------------------------------------- * * ZipFSLookupZip -- * * This function gets the structure for a mounted ZIP archive. * * Results: * Returns a pointer to the structure, or NULL if the file is ZIP file is * unknown/not mounted. * * Side effects: * None. | > | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 | /* *------------------------------------------------------------------------- * * ZipFSLookupZip -- * * This function gets the structure for a mounted ZIP archive. * The read lock must be held by the caller. * * Results: * Returns a pointer to the structure, or NULL if the file is ZIP file is * unknown/not mounted. * * Side effects: * None. |
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 | } /* *------------------------------------------------------------------------ * * ContainsMountPoint -- * | | | | | | | | | | | 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 |
}
/*
*------------------------------------------------------------------------
*
* ContainsMountPoint --
*
* Check if there is a mount point anywhere under the specified path.
* Although the function will work for any path, for efficiency reasons
* it should be called only after checking ZipFSLookup does not find
* the path.
*
* Caller must hold read lock before calling.
*
* Results:
* 1 - there is at least one mount point under the path
* 0 - otherwise
*
* Side effects:
* None.
*
*------------------------------------------------------------------------
*/
static int
ContainsMountPoint(
const char *path,
Tcl_Size pathLen)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (ZipFS.zipHash.numEntries == 0) {
return 0;
}
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
* Enumerate the contents of the ZIP; it's mounted on the root.
* TODO - a holdover from androwish? Tcl does not allow mounting
* outside of the //zipfs:/ area.
*/
ZipEntry *z;
for (z = zf->topEnts; z; z = z->tnext) {
| | | | > | | | | | | | | 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 |
* Enumerate the contents of the ZIP; it's mounted on the root.
* TODO - a holdover from androwish? Tcl does not allow mounting
* outside of the //zipfs:/ area.
*/
ZipEntry *z;
for (z = zf->topEnts; z; z = z->tnext) {
Tcl_Size lenz = ZipEntryNameLength(z);
if ((lenz >= pathLen)
&& (z->name[pathLen] == '/' ||
z->name[pathLen] == '\0')
&& !strncmp(z->name, path, pathLen)) {
return 1;
}
}
} else if ((zf->mountPointLen >= pathLen)
&& (zf->mountPoint[pathLen] == '/' ||
zf->mountPoint[pathLen] == '\0' ||
pathLen == ZIPFS_VOLUME_LEN)
&& !strncmp(zf->mountPoint, path, pathLen)) {
/* Matched standard mount */
return 1;
}
}
return 0;
}
/*
*-------------------------------------------------------------------------
*
* AllocateZipFile, AllocateZipEntry, AllocateZipChannel --
*
* Allocates the memory for a datastructure. Always ensures that it is
* zeroed out for safety.
|
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
}
static inline ZipEntry *
AllocateZipEntry(void)
{
ZipEntry *z = (ZipEntry *) Tcl_Alloc(sizeof(ZipEntry));
memset(z, 0, sizeof(ZipEntry));
return z;
}
static inline ZipChannel *
AllocateZipChannel(
Tcl_Interp *interp)
{
| > | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 |
}
static inline ZipEntry *
AllocateZipEntry(void)
{
ZipEntry *z = (ZipEntry *) Tcl_Alloc(sizeof(ZipEntry));
memset(z, 0, sizeof(ZipEntry));
z->nameLen = TCL_AUTO_LENGTH;
return z;
}
static inline ZipChannel *
AllocateZipChannel(
Tcl_Interp *interp)
{
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 | * * This function takes a memory mapped zip file and indexes the contents. * When "needZip" is zero an embedded ZIP archive in an executable file * is accepted. Note that we do not support ZIP64. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed | | | | | | 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 |
*
* This function takes a memory mapped zip file and indexes the contents.
* When "needZip" is zero an embedded ZIP archive in an executable file
* is accepted. Note that we do not support ZIP64.
*
* Results:
* TCL_OK on success, TCL_ERROR otherwise with an error message placed
* into the given interp if it is not NULL.
*
* Side effects:
* The given ZipFile struct is filled with information about the ZIP
* archive file. On error, ZipFSCloseArchive is called on zf but
* it is not freed.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSFindTOC(
Tcl_Interp *interp, /* Current interpreter. NULLable. */
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
/*
* Scan backwards from the end of the file for the signature. This is
* necessary because ZIP archives aren't the only things that get tagged
* on the end of executables; digital signatures can also go there.
*/
| | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
/*
* Scan backwards from the end of the file for the signature. This is
* necessary because ZIP archives aren't the only things that get tagged
* on the end of executables; digital signatures can also go there.
*/
eocdPtr = zf->data + zf->length - CENTRAL_END_LEN;
while (eocdPtr >= start) {
if (*eocdPtr == (ZIP_CENTRAL_END_SIG & 0xFF)) {
if (ZipReadInt(start, end, eocdPtr) == ZIP_CENTRAL_END_SIG) {
break;
}
eocdPtr -= ZIP_SIG_LEN;
} else {
|
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 |
if (!needZip) {
zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
}
ZIPFS_ERROR(interp, "archive directory end signature not found");
ZIPFS_ERROR_CODE(interp, "END_SIG");
| | < | | > | | > | > | | | | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
if (!needZip) {
zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
}
ZIPFS_ERROR(interp, "archive directory end signature not found");
ZIPFS_ERROR_CODE(interp, "END_SIG");
error:
ZipFSCloseArchive(interp, zf);
return TCL_ERROR;
}
/*
* eocdPtr -> End of Central Directory (EOCD) record at this point.
* Note this is not same as "end of Central Directory" :-) as EOCD
* is a record/structure in the ZIP spec terminology
*/
/*
* How many files in the archive? If that's bogus, we're done here.
*/
zf->numFiles = ZipReadShort(start, end, eocdPtr + CENTRAL_ENTS);
if (zf->numFiles == 0) {
if (!needZip) {
zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
}
ZIPFS_ERROR(interp, "empty archive");
ZIPFS_ERROR_CODE(interp, "EMPTY");
goto error;
}
/*
* The Central Directory (CD) is a series of Central Directory File
* Header (CDFH) records preceding the EOCD (but not necessarily
* immediately preceding). cdirZipOffset is the offset into the
* *archive* to the CD (first CDFH). The size of the CD is given by
* cdirSize. NOTE: offset into archive does NOT mean offset into
* (zf->data) as other data may precede the archive in the file.
*/
ptrdiff_t eocdDataOffset = eocdPtr - zf->data;
unsigned int cdirZipOffset = ZipReadInt(start, end,
eocdPtr + CENTRAL_DIRSTART);
unsigned int cdirSize = ZipReadInt(start, end, eocdPtr + CENTRAL_DIRSIZE);
/*
* As computed above,
* eocdDataOffset < zf->length.
* In addition, the following consistency checks must be met
* (1) cdirZipOffset <= eocdDataOffset (to prevent under flow in
* computation of (2))
* (2) cdirZipOffset + cdirSize <= eocdDataOffset. Else the CD will be
* overlapping the EOCD. Note this automatically means
* cdirZipOffset+cdirSize < zf->length.
*/
if (!(cdirZipOffset <= (size_t)eocdDataOffset
&& cdirSize <= eocdDataOffset - cdirZipOffset)) {
if (!needZip) {
/* Simply point to end od data */
zf->directoryOffset = zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
}
ZIPFS_ERROR(interp, "archive directory truncated");
ZIPFS_ERROR_CODE(interp, "NO_DIR");
|
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
zf->passOffset = zf->baseOffset;
zf->directoryOffset = cdirZipOffset + zf->baseOffset;
zf->directorySize = cdirSize;
/*
* Read the central directory.
*/
| | > > | | | | | | | | | > | | | | 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 |
zf->passOffset = zf->baseOffset;
zf->directoryOffset = cdirZipOffset + zf->baseOffset;
zf->directorySize = cdirSize;
/*
* Read the central directory.
*/
const unsigned char *const cdirStart = eocdPtr - cdirSize; // Start of CD
const unsigned char *dirEntry;
minoff = zf->length;
for (dirEntry = cdirStart, i = 0; i < zf->numFiles; i++) {
#define Get(typ, base, off) ZipRead##typ(start, end, (base) + (off))
if ((dirEntry - cdirStart) + CENTRAL_HEADER_LEN
> (ptrdiff_t) zf->directorySize) {
ZIPFS_ERROR(interp, "truncated directory");
ZIPFS_ERROR_CODE(interp, "TRUNC_DIR");
goto error;
}
if (Get(Int, dirEntry, CENTRAL_SIG) != ZIP_CENTRAL_HEADER_SIG) {
ZIPFS_ERROR(interp, "wrong header signature");
ZIPFS_ERROR_CODE(interp, "HDR_SIG");
goto error;
}
int pathlen = Get(Short, dirEntry, CENTRAL_PATHLEN);
int comlen = Get(Short, dirEntry, CENTRAL_FCOMMENTLEN);
int extra = Get(Short, dirEntry, CENTRAL_EXTRALEN);
size_t localhdr_off = Get(Int, dirEntry, CENTRAL_LOCALHDR);
const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off;
if (localP > (cdirStart - LOCAL_HEADER_LEN) ||
Get(Int, localP, LOCAL_SIG) != ZIP_LOCAL_HEADER_SIG) {
ZIPFS_ERROR(interp, "Failed to find local header");
ZIPFS_ERROR_CODE(interp, "LCL_HDR");
goto error;
}
if (localhdr_off < minoff) {
minoff = localhdr_off;
}
dirEntry += pathlen + comlen + extra + CENTRAL_HEADER_LEN;
#undef Get
}
if ((dirEntry - cdirStart) < (ptrdiff_t) zf->directorySize) {
/* file count and dir size do not match */
ZIPFS_ERROR(interp, "short file count");
ZIPFS_ERROR_CODE(interp, "FILE_COUNT");
goto error;
}
zf->passOffset = minoff + zf->baseOffset;
/*
* If there's also an encoded password, extract that too (but don't decode
* yet).
* TODO - is this even part of the ZIP "standard". The idea of storing
* a password with the archive seems absurd, encoded or not.
*/
unsigned char *q = zf->data + zf->passOffset;
if ((zf->passOffset >= 6) && (start < q - 4)
&& (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) {
const unsigned char *passPtr;
i = q[-5];
passPtr = q - 5 - i;
if (passPtr >= start && passPtr + i < end) {
zf->passBuf[0] = i;
memcpy(zf->passBuf + 1, passPtr, i);
|
| ︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 | * buffer. The ZIP archive header is verified and must be valid for the * function to succeed. When "needZip" is zero an embedded ZIP archive in * an executable file is accepted. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. On error, ZipFSCloseArchive | | | 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 | * buffer. The ZIP archive header is verified and must be valid for the * function to succeed. When "needZip" is zero an embedded ZIP archive in * an executable file is accepted. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given "interp" if it is not NULL. On error, ZipFSCloseArchive * is called on zf but it is not freed. * * Side effects: * ZIP archive is memory mapped or read into allocated memory, the given * ZipFile struct is filled with information about the ZIP archive file. * *------------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1657 1658 1659 1660 1661 1662 1663 |
*/
zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
if (zf->length == (size_t) TCL_INDEX_NONE) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
| < | | | | > | 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 |
*/
zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
if (zf->length == (size_t) TCL_INDEX_NONE) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
if ((zf->length <= CENTRAL_END_LEN) ||
(zf->length - CENTRAL_END_LEN) >
(ZIPFS_MAX_DIR_SIZE - CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
zf->ptrToFree = zf->data = (unsigned char *)
Tcl_AttemptAlloc(zf->length);
if (!zf->ptrToFree) {
ZIPFS_MEM_ERROR(interp);
goto error;
}
i = Tcl_Read(zf->chan, (char *) zf->data, zf->length);
if (i != zf->length) {
ZIPFS_POSIX_ERROR(interp, "file read error");
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 |
readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0;
if (!readSuccessful) {
Tcl_WinConvertError(GetLastError());
ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
return TCL_ERROR;
}
| | | 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 |
readSuccessful = GetFileSizeEx(hFile, (PLARGE_INTEGER) &zf->length) != 0;
if (!readSuccessful) {
Tcl_WinConvertError(GetLastError());
ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
return TCL_ERROR;
}
if (zf->length < CENTRAL_END_LEN) {
Tcl_SetErrno(EINVAL);
ZIPFS_POSIX_ERROR(interp, "truncated file");
return TCL_ERROR;
}
if (zf->length > TCL_SIZE_MAX) {
Tcl_SetErrno(EFBIG);
ZIPFS_POSIX_ERROR(interp, "zip archive too big");
|
| ︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 |
int fd = PTR2INT(handle);
/*
* Determine the file size.
*/
zf->length = lseek(fd, 0, SEEK_END);
| | | | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 |
int fd = PTR2INT(handle);
/*
* Determine the file size.
*/
zf->length = lseek(fd, 0, SEEK_END);
if ((off_t)zf->length == (off_t)-1) {
ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
return TCL_ERROR;
}
if (zf->length < CENTRAL_END_LEN) {
Tcl_SetErrno(EINVAL);
ZIPFS_POSIX_ERROR(interp, "truncated file");
return TCL_ERROR;
}
lseek(fd, 0, SEEK_SET);
zf->data = (unsigned char *)
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 | * ZipFSCatalogFilesystem -- * * This function generates the root node for a ZIPFS filesystem by * reading the ZIP's central directory. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed | | | 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 | * ZipFSCatalogFilesystem -- * * This function generates the root node for a ZIPFS filesystem by * reading the ZIP's central directory. * * Results: * TCL_OK on success, TCL_ERROR otherwise with an error message placed * into the given interp if it is not NULL. On error, frees zf!! * * Side effects: * Will acquire and release the write lock. * *------------------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 1962 |
for (i = 0; i < zf->numFiles; i++) {
const unsigned char *start = zf->data;
const unsigned char *end = zf->data + zf->length;
int extra, isdir = 0, dosTime, dosDate, nbcompr;
size_t offs, pathlen, comlen;
unsigned char *lq, *gq = NULL;
char *fullpath, *path;
| > | | | | | | < | | | | | | | | | | | < < | < | | | < | | < | | | < | | < > | > | | | 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 |
for (i = 0; i < zf->numFiles; i++) {
const unsigned char *start = zf->data;
const unsigned char *end = zf->data + zf->length;
int extra, isdir = 0, dosTime, dosDate, nbcompr;
size_t offs, pathlen, comlen;
unsigned char *lq, *gq = NULL;
char *fullpath, *path;
#define Get(typ, base, off) ZipRead##typ(start, end, (base) + (off))
pathlen = Get(Short, q, CENTRAL_PATHLEN);
comlen = Get(Short, q, CENTRAL_FCOMMENTLEN);
extra = Get(Short, q, CENTRAL_EXTRALEN);
Tcl_DStringSetLength(&ds, 0);
path = DecodeZipEntryText(q + CENTRAL_HEADER_LEN, pathlen, &ds);
if ((pathlen > 0) && (path[pathlen - 1] == '/')) {
Tcl_DStringSetLength(&ds, pathlen - 1);
path = Tcl_DStringValue(&ds);
isdir = 1;
}
if (!strcmp(path, ".") || !strcmp(path, "..")) {
goto nextent;
}
lq = zf->data + zf->baseOffset + Get(Int, q, CENTRAL_LOCALHDR);
if ((lq < start) || (lq + LOCAL_HEADER_LEN > end)) {
goto nextent;
}
nbcompr = Get(Int, lq, LOCAL_COMPLEN);
if (!isdir && (nbcompr == 0)
&& (Get(Int, lq, LOCAL_UNCOMPLEN) == 0)
&& (Get(Int, lq, LOCAL_CRC32) == 0)) {
gq = q;
nbcompr = Get(Int, gq, CENTRAL_COMPLEN);
}
offs = (lq - zf->data)
+ LOCAL_HEADER_LEN
+ Get(Short, lq, LOCAL_PATHLEN)
+ Get(Short, lq, LOCAL_EXTRALEN);
if (offs + nbcompr > zf->length) {
goto nextent;
}
if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) {
#ifdef ANDROID
/*
* When mounting the ZIP archive on the root directory try to
* remap top level regular files of the archive to
* /assets/.root/... since this directory should not be in a valid
* APK due to the leading dot in the file name component. This
* trick should make the files AndroidManifest.xml,
* resources.arsc, and classes.dex visible to Tcl.
*/
Tcl_DString ds2;
Tcl_DStringInit(&ds2);
TclDStringAppendLiteral(&ds2, "assets/.root/");
Tcl_DStringAppend(&ds2, path, TCL_AUTO_LENGTH);
if (ZipFSLookup(Tcl_DStringValue(&ds2))) {
/* should not happen but skip it anyway */
Tcl_DStringFree(&ds2);
goto nextent;
}
Tcl_DStringSetLength(&ds, 0);
path = TclDStringAppendDString(&ds, &ds2);
Tcl_DStringFree(&ds2);
#else /* !ANDROID */
/*
* Regular files skipped when mounting on root.
*/
goto nextent;
#endif /* ANDROID */
}
Tcl_DStringSetLength(&fpBuf, 0);
fullpath = MapPathToZipfs(interp, mountPoint, path, &fpBuf);
z = AllocateZipEntry();
z->depth = CountSlashes(fullpath);
assert(z->depth >= ZIPFS_ROOTDIR_DEPTH);
z->zipFilePtr = zf;
z->isDirectory = isdir;
z->isEncrypted = (Get(Short, lq, LOCAL_FLAGS) & 1)
&& (nbcompr > ZIP_CRYPT_HDR_LEN);
z->offset = offs;
if (gq) {
z->crc32 = Get(Int, gq, CENTRAL_CRC32);
dosDate = Get(Short, gq, CENTRAL_MDATE);
dosTime = Get(Short, gq, CENTRAL_MTIME);
z->timestamp = DosTimeDate(dosDate, dosTime);
z->numBytes = Get(Int, gq, CENTRAL_UNCOMPLEN);
z->compressMethod = Get(Short, gq, CENTRAL_COMPMETH);
} else {
z->crc32 = Get(Int, lq, LOCAL_CRC32);
dosDate = Get(Short, lq, LOCAL_MDATE);
dosTime = Get(Short, lq, LOCAL_MTIME);
z->timestamp = DosTimeDate(dosDate, dosTime);
z->numBytes = Get(Int, lq, LOCAL_UNCOMPLEN);
z->compressMethod = Get(Short, lq, LOCAL_COMPMETH);
}
#undef Get
z->numCompressedBytes = nbcompr;
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
if (!isNew) {
/* should not happen but skip it anyway */
Tcl_Free(z);
goto nextent;
}
Tcl_SetHashValue(hPtr, z);
z->name = (char *) Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
z->next = zf->entries;
zf->entries = z;
if (isdir && (mountPoint[0] == '\0')
&& (z->depth == ZIPFS_ROOTDIR_DEPTH)) {
z->tnext = zf->topEnts;
zf->topEnts = z;
}
/*
* Make any directory nodes we need. ZIPs are not consistent about
* containing directory nodes.
*/
if (!z->isDirectory && (z->depth > ZIPFS_ROOTDIR_DEPTH)) {
char *dir, *endPtr;
ZipEntry *zd;
Tcl_DStringSetLength(&ds, ZipEntryNameLength(z) + 8);
Tcl_DStringSetLength(&ds, 0);
Tcl_DStringAppend(&ds, z->name, ZipEntryNameLength(z));
dir = Tcl_DStringValue(&ds);
for (endPtr = strrchr(dir, '/'); endPtr && (endPtr != dir);
endPtr = strrchr(dir, '/')) {
Tcl_DStringSetLength(&ds, endPtr - dir);
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
if (!isNew) {
/*
|
| ︙ | ︙ | |||
2112 2113 2114 2115 2116 2117 2118 |
if ((mountPoint[0] == '\0') && (zd->depth == ZIPFS_ROOTDIR_DEPTH)) {
zd->tnext = zf->topEnts;
zf->topEnts = zd;
}
}
}
nextent:
| | | 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 |
if ((mountPoint[0] == '\0') && (zd->depth == ZIPFS_ROOTDIR_DEPTH)) {
zd->tnext = zf->topEnts;
zf->topEnts = zd;
}
}
}
nextent:
q += pathlen + comlen + extra + CENTRAL_HEADER_LEN;
}
Unlock();
Tcl_DStringFree(&fpBuf);
Tcl_DStringFree(&ds);
Tcl_FSMountsChanged(NULL);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2201 2202 2203 2204 2205 2206 2207 |
}
TclNewObj(resultList);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *) Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
| | | | | | | | | 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 |
}
TclNewObj(resultList);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *) Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
zf->mountPoint, TCL_AUTO_LENGTH));
Tcl_ListObjAppendElement(NULL, resultList, Tcl_NewStringObj(
zf->name, TCL_AUTO_LENGTH));
}
Tcl_SetObjResult(interp, resultList);
return TCL_OK;
}
/*
*------------------------------------------------------------------------
*
* CleanupMount --
*
* Releases all resources associated with a mounted archive. There
* must not be any open files in the archive.
*
* Caller MUST be holding WriteLock() before calling this function.
*
* Results:
* None.
*
* Side effects:
* Memory associated with the mounted archive is deallocated.
*------------------------------------------------------------------------
*/
static void
CleanupMount(
ZipFile *zf) /* Mount point */
{
ZipEntry *z, *znext;
|
| ︙ | ︙ | |||
2245 2246 2247 2248 2249 2250 2251 |
if (z->data) {
Tcl_Free(z->data);
}
Tcl_Free(z);
}
zf->entries = NULL;
}
| | | 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 |
if (z->data) {
Tcl_Free(z->data);
}
Tcl_Free(z);
}
zf->entries = NULL;
}
/*
*-------------------------------------------------------------------------
*
* DescribeMounted --
*
* This procedure describes what is mounted at the given the mount point.
* The interpreter result is not updated if there is nothing mounted at
|
| ︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 |
Tcl_Interp *interp,
const char *mountPoint)
{
if (interp) {
ZipFile *zf = ZipFSLookupZip(mountPoint);
if (zf) {
| | > | 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 |
Tcl_Interp *interp,
const char *mountPoint)
{
if (interp) {
ZipFile *zf = ZipFSLookupZip(mountPoint);
if (zf) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(zf->name, TCL_AUTO_LENGTH));
return TCL_OK;
}
}
return (interp ? TCL_OK : TCL_BREAK);
}
/*
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 | /* Have both a mount point and a file (name) to mount there. */ Tcl_Obj *zipPathObj; Tcl_Obj *normZipPathObj; Unlock(); | | | 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 |
/* Have both a mount point and a file (name) to mount there. */
Tcl_Obj *zipPathObj;
Tcl_Obj *normZipPathObj;
Unlock();
zipPathObj = Tcl_NewStringObj(zipname, TCL_AUTO_LENGTH);
Tcl_IncrRefCount(zipPathObj);
normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj);
if (normZipPathObj == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not normalize zip filename \"%s\"", zipname));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", (char *)NULL);
ret = TCL_ERROR;
|
| ︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 |
ret = TCL_ERROR;
} else {
ret = ZipFSOpenArchive(interp, normPath, 1, zf);
if (ret != TCL_OK) {
Tcl_Free(zf);
} else {
ret = ZipFSCatalogFilesystem(
| | | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 |
ret = TCL_ERROR;
} else {
ret = ZipFSOpenArchive(interp, normPath, 1, zf);
if (ret != TCL_OK) {
Tcl_Free(zf);
} else {
ret = ZipFSCatalogFilesystem(
interp, zf, mountPoint, passwd, normPath);
/* Note zf is already freed on error! */
}
}
}
Tcl_DecrRefCount(normZipPathObj);
if (ret == TCL_OK && interp) {
Tcl_DStringResult(interp, &ds);
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 |
}
mountPoint = Tcl_DStringValue(&ds);
Unlock();
/*
* Have both a mount point and data to mount there.
| < | | | | | | 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 |
}
mountPoint = Tcl_DStringValue(&ds);
Unlock();
/*
* Have both a mount point and data to mount there.
*/
ret = TCL_ERROR;
if ((datalen <= CENTRAL_END_LEN) ||
(datalen - CENTRAL_END_LEN) >
(ZIPFS_MAX_DIR_SIZE - CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
ZIPFS_ERROR_CODE(interp, "FILE_SIZE");
goto done;
}
zf = AllocateZipFile(interp, strlen(mountPoint));
if (zf == NULL) {
goto done;
}
zf->isMemBuffer = 1;
zf->length = datalen;
if (copy) {
zf->data = (unsigned char *) Tcl_AttemptAlloc(datalen);
if (zf->data == NULL) {
ZipFSCloseArchive(interp, zf);
Tcl_Free(zf);
ZIPFS_MEM_ERROR(interp);
goto done;
}
memcpy(zf->data, data, datalen);
zf->ptrToFree = zf->data;
} else {
zf->data = (unsigned char *) data;
zf->ptrToFree = NULL;
}
ret = ZipFSFindTOC(interp, 1, zf);
if (ret != TCL_OK) {
Tcl_Free(zf);
} else {
/* Note ZipFSCatalogFilesystem will free zf on error */
|
| ︙ | ︙ | |||
2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 |
static int
ZipFSRootObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc,
Tcl_Obj *const *objv)
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
| > > | | 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 |
static int
ZipFSRootObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *volume;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
TclNewLiteralStringObj(volume, ZIPFS_VOLUME);
Tcl_SetObjResult(interp, volume);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSUnmountObjCmd --
|
| ︙ | ︙ | |||
2726 2727 2728 2729 2730 2731 2732 | } /* *------------------------------------------------------------------------- * * ZipFSMkKeyObjCmd -- * | | | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 | } /* *------------------------------------------------------------------------- * * ZipFSMkKeyObjCmd -- * * This procedure is invoked to process the [zipfs mkkey] command. It * produces a rotated password to be embedded into an image file. * * Results: * A standard Tcl result. * * Side effects: * None. |
| ︙ | ︙ | |||
2754 2755 2756 2757 2758 2759 2760 |
Tcl_Obj *passObj;
unsigned char *passBuf;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
| | | > | | | 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 |
Tcl_Obj *passObj;
unsigned char *passBuf;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
pw = Tcl_GetStringFromObj(objv[1], &len);
if (len == 0) {
return TCL_OK;
}
if (IsPasswordValid(interp, pw, len) != TCL_OK) {
return TCL_ERROR;
}
passObj = Tcl_NewByteArrayObj(NULL, ZIPFS_PASSBUF_SIZE);
passBuf = Tcl_GetBytesFromObj(NULL, passObj, (Tcl_Size *)NULL);
while (len > 0) {
int ch = pw[len - 1];
passBuf[i++] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f];
len--;
}
passBuf[i] = i;
i++;
ZipWriteInt(passBuf, passBuf + ZIPFS_PASSBUF_SIZE, passBuf + i,
ZIP_PASSWORD_END_SIG);
Tcl_SetByteArrayLength(passObj, i + 4);
Tcl_SetObjResult(interp, passObj);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* RandomChar --
*
* Worker for ZipAddFile(). Picks a random character (range: 0..255)
* using Tcl's standard PRNG.
*
* Returns:
* Tcl result code. Updates chPtr with random character on success.
*
* Side effects:
* Advances the PRNG state. May reenter the Tcl interpreter if the user
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
Tcl_Interp *interp,
int step,
int *chPtr)
{
double r;
Tcl_Obj *ret;
| | > | 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 |
Tcl_Interp *interp,
int step,
int *chPtr)
{
double r;
Tcl_Obj *ret;
if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", TCL_INDEX_NONE,
0) != TCL_OK) {
goto failed;
}
ret = Tcl_GetObjResult(interp);
if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) {
goto failed;
}
*chPtr = (int) (r * 256);
|
| ︙ | ︙ | |||
2895 2896 2897 2898 2899 2900 2901 |
}
/*
* Convert to encoded form. Note that we use strlen() here; if someone's
* crazy enough to embed NULs in filenames, they deserve what they get!
*/
| | > | | | 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 |
}
/*
* Convert to encoded form. Note that we use strlen() here; if someone's
* crazy enough to embed NULs in filenames, they deserve what they get!
*/
if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, zpathTcl,
TCL_INDEX_NONE, 0, &zpathDs, NULL) != TCL_OK) {
Tcl_DStringFree(&zpathDs);
return TCL_ERROR;
}
zpathExt = Tcl_DStringValue(&zpathDs);
zpathlen = strlen(zpathExt);
if (zpathlen + CENTRAL_HEADER_LEN > bufsize) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"path too long for \"%s\"", TclGetString(pathObj)));
ZIPFS_ERROR_CODE(interp, "PATH_LEN");
Tcl_DStringFree(&zpathDs);
return TCL_ERROR;
}
in = Tcl_FSOpenFileChannel(interp, pathObj, "rb", 0);
if (!in) {
Tcl_DStringFree(&zpathDs);
#ifdef _WIN32
/* hopefully a directory */
if (!strcmp("permission denied", Tcl_PosixError(interp))) {
Tcl_Close(interp, in);
return TCL_OK;
}
#endif /* _WIN32 */
Tcl_Close(interp, in);
return TCL_ERROR;
} else {
|
| ︙ | ︙ | |||
2975 2976 2977 2978 2979 2980 2981 |
headerStartOffset = Tcl_Tell(out);
/*
* Reserve space for the per-file header. Includes writing the file name
* as we already know that.
*/
| | | | | 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 |
headerStartOffset = Tcl_Tell(out);
/*
* Reserve space for the per-file header. Includes writing the file name
* as we already know that.
*/
memset(buf, '\0', LOCAL_HEADER_LEN);
memcpy(buf + LOCAL_HEADER_LEN, zpathExt, zpathlen);
len = zpathlen + LOCAL_HEADER_LEN;
if (Tcl_Write(out, buf, len) != len) {
writeErrorWithChannelOpen:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on \"%s\": %s",
TclGetString(pathObj), Tcl_PosixError(interp)));
Tcl_Close(interp, in);
Tcl_DStringFree(&zpathDs);
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 |
/*
* Set up encryption if we were asked to.
*/
if (passwd) {
int i, ch, tmp;
| | | > | 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 |
/*
* Set up encryption if we were asked to.
*/
if (passwd) {
int i, ch, tmp;
unsigned char kvbuf[2 * ZIP_CRYPT_HDR_LEN];
init_keys(passwd, keys, crc32tab);
for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
if (RandomChar(interp, i, &ch) != TCL_OK) {
Tcl_Close(interp, in);
return TCL_ERROR;
}
kvbuf[i + ZIP_CRYPT_HDR_LEN] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < ZIP_CRYPT_HDR_LEN - 2; i++) {
kvbuf[i] = UCHAR(zencode(keys, crc32tab,
kvbuf[i + ZIP_CRYPT_HDR_LEN], tmp));
}
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
len = Tcl_Write(out, (char *) kvbuf, ZIP_CRYPT_HDR_LEN);
memset(kvbuf, 0, sizeof(kvbuf));
if (len != ZIP_CRYPT_HDR_LEN) {
goto writeErrorWithChannelOpen;
|
| ︙ | ︙ | |||
3055 3056 3057 3058 3059 3060 3061 |
*/
compMeth = ZIP_COMPMETH_DEFLATED;
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
| | | 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 |
*/
compMeth = ZIP_COMPMETH_DEFLATED;
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
if (deflateInit2(&stream, 9, Z_DEFLATED, ZLIB_MODE_RAW, 8,
Z_DEFAULT_STRATEGY) != Z_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"compression init error on \"%s\"", TclGetString(pathObj)));
ZIPFS_ERROR_CODE(interp, "DEFLATE_INIT");
Tcl_Close(interp, in);
Tcl_DStringFree(&zpathDs);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 |
*/
if (Tcl_Seek(in, 0, SEEK_SET) != 0) {
goto seekErr;
}
if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) {
seekErr:
| < | | 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 |
*/
if (Tcl_Seek(in, 0, SEEK_SET) != 0) {
goto seekErr;
}
if (Tcl_Seek(out, dataStartOffset, SEEK_SET) != dataStartOffset) {
seekErr:
ZIPFS_POSIX_ERROR(interp, "seek error");
Tcl_Close(interp, in);
Tcl_DStringFree(&zpathDs);
return TCL_ERROR;
}
nbytecompr = (passwd ? ZIP_CRYPT_HDR_LEN : 0);
while (1) {
len = Tcl_Read(in, buf, bufsize);
|
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 |
*/
SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z,
zpathlen, align);
if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) {
Tcl_DeleteHashEntry(hPtr);
Tcl_Free(z);
| < | | < | < | | 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 |
*/
SerializeLocalEntryHeader(start, end, (unsigned char *) buf, z,
zpathlen, align);
if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) {
Tcl_DeleteHashEntry(hPtr);
Tcl_Free(z);
ZIPFS_POSIX_ERROR(interp, "seek error");
return TCL_ERROR;
}
if (Tcl_Write(out, buf, LOCAL_HEADER_LEN) != LOCAL_HEADER_LEN) {
Tcl_DeleteHashEntry(hPtr);
Tcl_Free(z);
ZIPFS_POSIX_ERROR(interp, "write error");
return TCL_ERROR;
}
Tcl_Flush(out);
if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) {
Tcl_DeleteHashEntry(hPtr);
Tcl_Free(z);
ZIPFS_POSIX_ERROR(interp, "seek error");
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
3239 3240 3241 3242 3243 3244 3245 |
ZipFSFind(
Tcl_Interp *interp,
Tcl_Obj *dirRoot)
{
Tcl_Obj *cmd[2];
int result;
| | | 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 |
ZipFSFind(
Tcl_Interp *interp,
Tcl_Obj *dirRoot)
{
Tcl_Obj *cmd[2];
int result;
TclNewLiteralStringObj(cmd[0], "::tcl::zipfs::find");
cmd[1] = dirRoot;
Tcl_IncrRefCount(cmd[0]);
result = Tcl_EvalObjv(interp, 2, cmd, 0);
Tcl_DecrRefCount(cmd[0]);
if (result != TCL_OK) {
return NULL;
}
|
| ︙ | ︙ | |||
3277 3278 3279 3280 3281 3282 3283 |
static inline const char *
ComputeNameInArchive(
Tcl_Obj *pathObj, /* The path to the origin file */
Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
* archive */
const char *strip, /* A prefix to strip; may be NULL if no
* stripping need be done. */
| | | | | 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 |
static inline const char *
ComputeNameInArchive(
Tcl_Obj *pathObj, /* The path to the origin file */
Tcl_Obj *directNameObj, /* User-specified name for use in the ZIP
* archive */
const char *strip, /* A prefix to strip; may be NULL if no
* stripping need be done. */
Tcl_Size slen) /* The length of the prefix; must be 0 if no
* stripping need be done. */
{
const char *name;
Tcl_Size len;
if (directNameObj) {
name = TclGetString(directNameObj);
} else {
name = Tcl_GetStringFromObj(pathObj, &len);
if (slen > 0) {
if ((len <= slen) || strncmp(strip, name, slen)) {
/*
* Guaranteed to be a NUL at the end, which will make this
* entry be skipped.
*/
return name + len;
}
|
| ︙ | ︙ | |||
3353 3354 3355 3356 3357 3358 3359 |
* there's no password protection. */
{
Tcl_Channel out;
int count, ret = TCL_ERROR;
Tcl_Size pwlen = 0, slen = 0, len, i = 0;
Tcl_Size lobjc;
long long directoryStartOffset;
| | | | | | 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 |
* there's no password protection. */
{
Tcl_Channel out;
int count, ret = TCL_ERROR;
Tcl_Size pwlen = 0, slen = 0, len, i = 0;
Tcl_Size lobjc;
long long directoryStartOffset;
/* The overall file offset of the start of the
* central directory. */
long long suffixStartOffset;/* The overall file offset of the start of the
* suffix of the central directory (i.e.,
* where this data will be written). */
Tcl_Obj **lobjv, *list = mappingList;
ZipEntry *z;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable fileHash;
char *strip = NULL, *pw = NULL, passBuf[ZIPFS_PASSBUF_SIZE], buf[4096];
unsigned char *start = (unsigned char *) buf;
unsigned char *end = start + sizeof(buf);
/*
* Caller has verified that the number of arguments is correct.
*/
passBuf[0] = 0;
if (passwordObj != NULL) {
pw = Tcl_GetStringFromObj(passwordObj, &pwlen);
if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) {
return TCL_ERROR;
}
if (pwlen == 0) {
pw = NULL;
}
}
|
| ︙ | ︙ | |||
3453 3454 3455 3456 3457 3458 3459 |
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *) Tcl_GetHashValue(hPtr);
| | < | | 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 |
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *) Tcl_GetHashValue(hPtr);
if (!strcmp(zf->name, imgName)) {
isMounted = 1;
zf->numOpen++;
break;
}
}
Unlock();
if (!isMounted) {
zf = &zf0;
memset(&zf0, 0, sizeof(ZipFile));
}
if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
/*
* Copy everything up to the ZIP-related suffix.
*/
if ((size_t) Tcl_Write(out, (char *) zf->data,
zf->passOffset) != zf->passOffset) {
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
ZIPFS_POSIX_ERROR(interp, "write error");
Tcl_Close(interp, out);
if (zf == &zf0) {
ZipFSCloseArchive(interp, zf);
} else {
WriteLock();
zf->numOpen--;
Unlock();
|
| ︙ | ︙ | |||
3516 3517 3518 3519 3520 3521 3522 |
*/
len = strlen(passBuf);
if (len > 0) {
i = Tcl_Write(out, passBuf, len);
if (i != len) {
Tcl_DecrRefCount(list);
| < | | | 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 |
*/
len = strlen(passBuf);
if (len > 0) {
i = Tcl_Write(out, passBuf, len);
if (i != len) {
Tcl_DecrRefCount(list);
ZIPFS_POSIX_ERROR(interp, "write error");
Tcl_Close(interp, out);
return TCL_ERROR;
}
}
memset(passBuf, 0, sizeof(passBuf));
Tcl_Flush(out);
}
/*
* Prepare the contents of the ZIP archive.
*/
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
if (mappingList == NULL && stripPrefix != NULL) {
strip = Tcl_GetStringFromObj(stripPrefix, &slen);
if (!slen) {
strip = NULL;
}
}
for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) {
Tcl_Obj *pathObj = lobjv[i];
const char *name = ComputeNameInArchive(pathObj,
|
| ︙ | ︙ | |||
3568 3569 3570 3571 3572 3573 3574 |
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *) Tcl_GetHashValue(hPtr);
| | > | < < | | < | | 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 |
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, z->name,
TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
ret = TCL_ERROR;
goto done;
}
name = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf,
z, len);
if ((Tcl_Write(out, buf, CENTRAL_HEADER_LEN) != CENTRAL_HEADER_LEN)
|| (Tcl_Write(out, name, len) != len)) {
ZIPFS_POSIX_ERROR(interp, "write error");
Tcl_DStringFree(&ds);
goto done;
}
Tcl_DStringFree(&ds);
count++;
}
/*
* Finalize the central directory.
*/
Tcl_Flush(out);
suffixStartOffset = Tcl_Tell(out);
SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf,
count, directoryStartOffset, suffixStartOffset);
if (Tcl_Write(out, buf, CENTRAL_END_LEN) != CENTRAL_END_LEN) {
ZIPFS_POSIX_ERROR(interp, "write error");
goto done;
}
Tcl_Flush(out);
ret = TCL_OK;
done:
if (ret == TCL_OK) {
|
| ︙ | ︙ | |||
3695 3696 3697 3698 3699 3700 3701 |
goto copyError;
}
}
Tcl_Close(interp, in);
return TCL_OK;
copyError:
| | < | 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 |
goto copyError;
}
}
Tcl_Close(interp, in);
return TCL_OK;
copyError:
ZIPFS_POSIX_ERROR(interp, errMsg);
Tcl_Close(interp, in);
return TCL_ERROR;
}
/*
* ---------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 |
*
* Side effects:
* Both update their buffer arguments, but otherwise change nothing.
*
* ---------------------------------------------------------------------
*/
static void
SerializeLocalEntryHeader(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
int nameLength, /* The length of the name. */
int align) /* The number of alignment bytes. */
{
| > > | | | < | < | < | | < | | | | < | | | < | < | < | < | | < | | | | | | | | < | < | | | | | < | < | | > > | | 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 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 |
*
* Side effects:
* Both update their buffer arguments, but otherwise change nothing.
*
* ---------------------------------------------------------------------
*/
#define Set(typ, off, val) ZipWrite##typ(start, end, buf + (off), (val))
static void
SerializeLocalEntryHeader(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
int nameLength, /* The length of the name. */
int align) /* The number of alignment bytes. */
{
Set(Int, LOCAL_SIG, ZIP_LOCAL_HEADER_SIG);
Set(Short, LOCAL_VERSION, ZIP_MIN_VERSION);
Set(Short, LOCAL_FLAGS, z->isEncrypted | ZIP_LOCAL_FLAGS_UTF8);
Set(Short, LOCAL_COMPMETH, z->compressMethod);
Set(Short, LOCAL_MTIME, ToDosTime(z->timestamp));
Set(Short, LOCAL_MDATE, ToDosDate(z->timestamp));
Set(Int, LOCAL_CRC32, z->crc32);
Set(Int, LOCAL_COMPLEN, z->numCompressedBytes);
Set(Int, LOCAL_UNCOMPLEN, z->numBytes);
Set(Short, LOCAL_PATHLEN, nameLength);
Set(Short, LOCAL_EXTRALEN, align);
}
static void
SerializeCentralDirectoryEntry(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
ZipEntry *z, /* The description of what to serialize. */
size_t nameLength) /* The length of the name. */
{
Set(Int, CENTRAL_SIG, ZIP_CENTRAL_HEADER_SIG);
Set(Short, CENTRAL_VERSIONMADE, ZIP_MIN_VERSION);
Set(Short, CENTRAL_VERSION, ZIP_MIN_VERSION);
Set(Short, CENTRAL_FLAGS, z->isEncrypted | ZIP_LOCAL_FLAGS_UTF8);
Set(Short, CENTRAL_COMPMETH, z->compressMethod);
Set(Short, CENTRAL_MTIME, ToDosTime(z->timestamp));
Set(Short, CENTRAL_MDATE, ToDosDate(z->timestamp));
Set(Int, CENTRAL_CRC32, z->crc32);
Set(Int, CENTRAL_COMPLEN, z->numCompressedBytes);
Set(Int, CENTRAL_UNCOMPLEN, z->numBytes);
Set(Short, CENTRAL_PATHLEN, nameLength);
Set(Short, CENTRAL_EXTRALEN, 0);
Set(Short, CENTRAL_FCOMMENTLEN, 0);
Set(Short, CENTRAL_DISKFILE, 0);
Set(Short, CENTRAL_IATTR, 0);
Set(Int, CENTRAL_EATTR, 0);
Set(Int, CENTRAL_LOCALHDR, z->offset);
}
static void
SerializeCentralDirectorySuffix(
const unsigned char *start, /* The start of writable memory. */
const unsigned char *end, /* The end of writable memory. */
unsigned char *buf, /* Where to serialize to */
int entryCount, /* The number of entries in the directory */
long long directoryStartOffset,
/* The overall file offset of the start of the
* central directory. */
long long suffixStartOffset)/* The overall file offset of the start of the
* suffix of the central directory (i.e.,
* where this data will be written). */
{
Set(Int, CENTRAL_END_SIG, ZIP_CENTRAL_END_SIG);
Set(Short, CENTRAL_DISKNO, 0);
Set(Short, CENTRAL_DISKDIR, 0);
Set(Short, CENTRAL_ENTS, entryCount);
Set(Short, CENTRAL_TOTALENTS, entryCount);
Set(Int, CENTRAL_DIRSIZE, suffixStartOffset - directoryStartOffset);
Set(Int, CENTRAL_DIRSTART, directoryStartOffset);
Set(Short, CENTRAL_COMMENTLEN, 0);
}
#undef Set
/*
*-------------------------------------------------------------------------
*
* ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd --
*
* These procedures are invoked to process the [zipfs mkzip] and [zipfs
* lmkzip] commands. See description of ZipFSMkZipOrImg().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See description of ZipFSMkZipOrImg().
*
|
| ︙ | ︙ | |||
3984 3985 3986 3987 3988 3989 3990 |
mntPoint = ZIPFS_VOLUME;
} else {
if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) {
return TCL_ERROR;
}
mntPoint = Tcl_DStringValue(&dsMount);
}
| < < | | | 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 |
mntPoint = ZIPFS_VOLUME;
} else {
if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) {
return TCL_ERROR;
}
mntPoint = Tcl_DStringValue(&dsMount);
}
(void) MapPathToZipfs(interp, mntPoint, Tcl_GetString(objv[objc - 1]),
&dsPath);
Tcl_SetObjResult(interp, Tcl_DStringToObj(&dsPath));
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4031 4032 4033 4034 4035 4036 4037 |
filename = TclGetString(objv[1]);
ReadLock();
exists = ZipFSLookup(filename) != NULL;
if (!exists) {
/* An ancestor directory of a file ? */
| | < | 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 |
filename = TclGetString(objv[1]);
ReadLock();
exists = ZipFSLookup(filename) != NULL;
if (!exists) {
/* An ancestor directory of a file ? */
exists = ContainsMountPoint(filename, TCL_AUTO_LENGTH);
}
Unlock();
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
4081 4082 4083 4084 4085 4086 4087 |
filename = TclGetString(objv[1]);
ReadLock();
z = ZipFSLookup(filename);
if (z) {
Tcl_Obj *result = Tcl_GetObjResult(interp);
Tcl_ListObjAppendElement(interp, result,
| | < | | | < | | 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 4193 4194 4195 |
filename = TclGetString(objv[1]);
ReadLock();
z = ZipFSLookup(filename);
if (z) {
Tcl_Obj *result = Tcl_GetObjResult(interp);
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->zipFilePtr->name, TCL_AUTO_LENGTH));
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj(z->numBytes));
Tcl_ListObjAppendElement(interp, result,
Tcl_NewWideIntObj(z->numCompressedBytes));
Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset));
ret = TCL_OK;
} else {
Tcl_SetErrno(ENOENT);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"path \"%s\" not found in any zipfs volume",
filename));
ret = TCL_ERROR;
}
Unlock();
return ret;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSListObjCmd --
*
* This procedure is invoked to process the [zipfs list] command. On
* success, it returns a Tcl list of files of the ZIP filesystem which
|
| ︙ | ︙ | |||
4176 4177 4178 4179 4180 4181 4182 |
if (pattern) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if (Tcl_StringMatch(z->name, pattern)) {
Tcl_ListObjAppendElement(interp, result,
| | | | | 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 |
if (pattern) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if (Tcl_StringMatch(z->name, pattern)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, TCL_AUTO_LENGTH));
}
}
} else if (regexp) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, TCL_AUTO_LENGTH));
}
}
} else {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *) Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, TCL_AUTO_LENGTH));
}
}
Unlock();
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
4226 4227 4228 4229 4230 4231 4232 |
*/
/* Utility routine to centralize housekeeping */
static Tcl_Obj *
ScriptLibrarySetup(
const char *dirName)
{
| | | 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 |
*/
/* Utility routine to centralize housekeeping */
static Tcl_Obj *
ScriptLibrarySetup(
const char *dirName)
{
Tcl_Obj *libDirObj = Tcl_NewStringObj(dirName, TCL_AUTO_LENGTH);
Tcl_Obj *subDirObj, *searchPathObj;
TclNewLiteralStringObj(subDirObj, "encoding");
Tcl_IncrRefCount(subDirObj);
TclNewObj(searchPathObj);
Tcl_ListObjAppendElement(NULL, searchPathObj,
Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
|
| ︙ | ︙ | |||
4268 4269 4270 4271 4272 4273 4274 |
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
/*
* Look for the library file system within the executable.
*/
| > | < | | > > | > | | 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 |
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
/*
* Look for the library file system within the executable.
*/
TclNewLiteralStringObj(vfsInitScript,
ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
/*
* Look for the library file system within the DLL/shared library. Note
* that we must mount the zip file and dll before releasing to search.
*/
#if !defined(STATIC_BUILD)
#if defined(_WIN32) || defined(__CYGWIN__)
hModule = (HMODULE) TclWinGetTclInstance();
GetModuleFileNameW(hModule, wName, MAX_PATH);
#ifdef __CYGWIN__
cygwin_conv_path(3, wName, dllName, sizeof(dllName));
#else
WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL,
NULL);
#endif
if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#elif !defined(NO_DLFCN_H)
Dl_info dlinfo;
if (dladdr((const void *) TclZipfs_TclLibrary, &dlinfo)
&& (dlinfo.dli_fname != NULL)
&& (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#else
if (ZipfsAppHookFindTclInit(
CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
#endif /* _WIN32 */
#endif /* !defined(STATIC_BUILD) */
/*
* If anything set the cache (but subsequently failed) go with that
|
| ︙ | ︙ | |||
4398 4399 4400 4401 4402 4403 4404 |
if (ZipChannelWritable(info)) {
/*
* Copy channel data back into original file in archive.
*/
ZipEntry *z = info->zipEntryPtr;
assert(info->ubufToFree && info->ubuf);
unsigned char *newdata;
| | | | | 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 |
if (ZipChannelWritable(info)) {
/*
* Copy channel data back into original file in archive.
*/
ZipEntry *z = info->zipEntryPtr;
assert(info->ubufToFree && info->ubuf);
unsigned char *newdata;
newdata = (unsigned char *) Tcl_AttemptRealloc(
info->ubufToFree,
info->numBytes ? info->numBytes : 1); /* Bug [23dd83ce7c] */
if (newdata == NULL) {
/* Could not reallocate, keep existing buffer */
newdata = info->ubufToFree;
}
info->ubufToFree = NULL; /* Now newdata! */
info->ubuf = NULL;
info->ubufSize = 0;
|
| ︙ | ︙ | |||
4575 4576 4577 4578 4579 4580 4581 |
Tcl_Size needed = info->cursor + toWrite;
/* Tack on a bit for future growth. */
if (needed < (info->maxWrite - needed/2)) {
needed += needed / 2;
} else {
needed = info->maxWrite;
}
| | | | 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 |
Tcl_Size needed = info->cursor + toWrite;
/* Tack on a bit for future growth. */
if (needed < (info->maxWrite - needed/2)) {
needed += needed / 2;
} else {
needed = info->maxWrite;
}
unsigned char *newBuf = (unsigned char *)
Tcl_AttemptRealloc(info->ubufToFree, needed);
if (newBuf == NULL) {
*errloc = ENOMEM;
return -1;
}
info->ubufToFree = newBuf;
info->ubuf = info->ubufToFree;
info->ubufSize = needed;
|
| ︙ | ︙ | |||
4751 4752 4753 4754 4755 4756 4757 |
int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
/* Check for unsupported modes. */
if ((ZipFS.wrmax <= 0) && wr) {
Tcl_SetErrno(EACCES);
| < < | < < | 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 |
int wr = (mode & (O_WRONLY | O_RDWR)) != 0;
/* Check for unsupported modes. */
if ((ZipFS.wrmax <= 0) && wr) {
Tcl_SetErrno(EACCES);
ZIPFS_POSIX_ERROR(interp, "writes not permitted");
return NULL;
}
if ((mode & (O_APPEND|O_TRUNC)) && !wr) {
Tcl_SetErrno(EINVAL);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
4799 4800 4801 4802 4803 4804 4805 |
goto error;
}
/* Do we support opening the file that way? */
if (wr && z->isDirectory) {
Tcl_SetErrno(EISDIR);
| < < | < < | 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 |
goto error;
}
/* Do we support opening the file that way? */
if (wr && z->isDirectory) {
Tcl_SetErrno(EISDIR);
ZIPFS_POSIX_ERROR(interp, "unsupported file type");
goto error;
}
if ((z->compressMethod != ZIP_COMPMETH_STORED)
&& (z->compressMethod != ZIP_COMPMETH_DEFLATED)) {
ZIPFS_ERROR(interp, "unsupported compression method");
ZIPFS_ERROR_CODE(interp, "COMP_METHOD");
goto error;
|
| ︙ | ︙ | |||
4830 4831 4832 4833 4834 4835 4836 |
/* Read-only */
flags |= TCL_READABLE;
}
if (z->isEncrypted) {
if (z->numCompressedBytes < ZIP_CRYPT_HDR_LEN) {
ZIPFS_ERROR(interp,
| | | 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 |
/* Read-only */
flags |= TCL_READABLE;
}
if (z->isEncrypted) {
if (z->numCompressedBytes < ZIP_CRYPT_HDR_LEN) {
ZIPFS_ERROR(interp,
"decryption failed: truncated decryption header");
ZIPFS_ERROR_CODE(interp, "DECRYPT");
goto error;
}
if (z->zipFilePtr->passBuf[0] == 0) {
ZIPFS_ERROR(interp, "decryption failed - no password provided");
ZIPFS_ERROR_CODE(interp, "DECRYPT");
goto error;
|
| ︙ | ︙ | |||
4946 4947 4948 4949 4950 4951 4952 |
* Set up a writable channel.
*/
info->mode = mode;
info->maxWrite = ZipFS.wrmax;
info->ubufSize = z->numBytes ? z->numBytes : 1;
| | | 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 |
* Set up a writable channel.
*/
info->mode = mode;
info->maxWrite = ZipFS.wrmax;
info->ubufSize = z->numBytes ? z->numBytes : 1;
info->ubufToFree = (unsigned char *) Tcl_AttemptAlloc(info->ubufSize);
info->ubuf = info->ubufToFree;
if (info->ubufToFree == NULL) {
goto memoryError;
}
if (z->isEncrypted) {
assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
|
| ︙ | ︙ | |||
4997 4998 4999 5000 5001 5002 5003 |
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
unsigned int j;
| | > > | | | | | 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 |
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
unsigned int j;
/* Min length ZIP_CRYPT_HDR_LEN for keys should already been
* checked. */
assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN);
stream.avail_in -= ZIP_CRYPT_HDR_LEN;
cbuf = (unsigned char *)
Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1);
if (!cbuf) {
goto memoryError;
}
for (j = 0; j < stream.avail_in; j++) {
ch = zbuf[j];
cbuf[j] = zdecode(info->keys, crc32tab, ch);
}
stream.next_in = cbuf;
} else {
stream.next_in = zbuf;
}
stream.next_out = info->ubuf;
stream.avail_out = info->ubufSize;
if (inflateInit2(&stream, ZLIB_MODE_RAW) != Z_OK) {
goto corruptionError;
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err != Z_STREAM_END)
&& ((err != Z_OK) || (stream.avail_in != 0))) {
goto corruptionError;
}
/* Even if decompression succeeded, counts should be as expected */
if ((int) stream.total_out != z->numBytes) {
goto corruptionError;
}
info->numBytes = z->numBytes;
|
| ︙ | ︙ | |||
5115 5116 5117 5118 5119 5120 5121 |
ZipChannel *info, /* The channel to set up. */
ZipEntry *z) /* The zipped file that the channel will read
* from. */
{
unsigned char *ubuf = NULL;
int ch;
| | | > | | | | 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 |
ZipChannel *info, /* The channel to set up. */
ZipEntry *z) /* The zipped file that the channel will read
* from. */
{
unsigned char *ubuf = NULL;
int ch;
info->isCompressed = (z->compressMethod == ZIP_COMPMETH_DEFLATED);
info->ubuf = z->zipFilePtr->data + z->offset;
info->ubufToFree = NULL; /* ubuf memory not allocated */
info->ubufSize = 0;
info->isDirectory = z->isDirectory;
info->isEncrypted = z->isEncrypted;
info->mode = O_RDONLY;
/* Caller must validate - bug [6ed3447a7e] */
assert(z->numBytes >= 0 && z->numCompressedBytes >= 0);
info->numBytes = z->numBytes;
if (info->isEncrypted) {
assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/
if (DecodeCryptHeader(interp, z, info->keys, info->ubuf) != TCL_OK) {
goto error_cleanup;
}
info->ubuf += ZIP_CRYPT_HDR_LEN;
}
if (info->isCompressed) {
z_stream stream;
int err;
unsigned int j;
/*
* Data to decode is compressed, and possibly encrpyted too. If
* encrypted, local variable ubuf is used to hold the decrypted but
* still compressed data.
*/
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (info->isEncrypted) {
assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN);
stream.avail_in -= ZIP_CRYPT_HDR_LEN;
ubuf = (unsigned char *)
Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1);
if (!ubuf) {
goto memoryError;
}
for (j = 0; j < stream.avail_in; j++) {
ch = info->ubuf[j];
ubuf[j] = zdecode(info->keys, crc32tab, ch);
}
stream.next_in = ubuf;
} else {
stream.next_in = info->ubuf;
}
info->ubufSize = info->numBytes ? info->numBytes : 1;
info->ubufToFree = (unsigned char *) Tcl_AttemptAlloc(info->ubufSize);
info->ubuf = info->ubufToFree;
stream.next_out = info->ubuf;
if (!info->ubuf) {
goto memoryError;
}
stream.avail_out = info->numBytes;
if (inflateInit2(&stream, ZLIB_MODE_RAW) != Z_OK) {
goto corruptionError;
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
/*
* Decompression was successful if we're either in the END state, or
|
| ︙ | ︙ | |||
5291 5292 5293 5294 5295 5296 5297 | buf->st_mode = S_IFREG | 0555; } buf->st_size = z->numBytes; buf->st_mtime = z->timestamp; buf->st_ctime = z->timestamp; buf->st_atime = z->timestamp; ret = 0; | | | 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 |
buf->st_mode = S_IFREG | 0555;
}
buf->st_size = z->numBytes;
buf->st_mtime = z->timestamp;
buf->st_ctime = z->timestamp;
buf->st_atime = z->timestamp;
ret = 0;
} else if (ContainsMountPoint(path, TCL_AUTO_LENGTH)) {
/* An intermediate dir under which a mount exists */
memset(buf, 0, sizeof(Tcl_StatBuf));
Tcl_Time t;
Tcl_GetTime(&t);
buf->st_atime = buf->st_mtime = buf->st_ctime = t.sec;
buf->st_mode = S_IFDIR | 0555;
ret = 0;
|
| ︙ | ︙ | |||
5347 5348 5349 5350 5351 5352 5353 |
if (mode & W_OK) {
access = -1;
} else {
/*
* Even if entry does not exist, could be intermediate dir
* containing a mount point
*/
| | | | 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 |
if (mode & W_OK) {
access = -1;
} else {
/*
* Even if entry does not exist, could be intermediate dir
* containing a mount point
*/
access = ContainsMountPoint(path, TCL_AUTO_LENGTH) ? 0 : -1;
}
}
Unlock();
return access;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSOpenFileChannelProc --
*
* Open a channel to a file in a mounted ZIP archive. Delegates to
* ZipChannelOpen().
|
| ︙ | ︙ | |||
5385 5386 5387 5388 5389 5390 5391 |
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return NULL;
}
return ZipChannelOpen(interp, Tcl_GetString(pathPtr), mode);
}
| | | 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 |
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return NULL;
}
return ZipChannelOpen(interp, Tcl_GetString(pathPtr), mode);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSStatProc --
*
* This function implements the ZIP filesystem specific version of the
* library version of stat.
|
| ︙ | ︙ | |||
5467 5468 5469 5470 5471 5472 5473 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
| | | | > | 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 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 5587 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("/", 1);
}
/*
*-------------------------------------------------------------------------
*
* AppendWithPrefix --
*
* Worker for ZipFSMatchInDirectoryProc() that is a wrapper around
* Tcl_ListObjAppendElement() which knows about handling prefixes.
*
*-------------------------------------------------------------------------
*/
static inline void
AppendWithPrefix(
Tcl_Obj *result, /* Where to append a list element to. */
Tcl_DString *prefix, /* The prefix to add to the element, or NULL
* for don't do that. */
const char *name, /* The name to append. */
size_t nameLen) /* The length of the name. May be TCL_INDEX_NONE
* for append-up-to-NUL-byte. */
{
if (prefix) {
size_t prefixLength = Tcl_DStringLength(prefix);
Tcl_DStringAppend(prefix, name, nameLen);
/* Don't use Tcl_DStringToObj(); we want to reuse prefix. */
Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
Tcl_DStringValue(prefix), Tcl_DStringLength(prefix)));
Tcl_DStringSetLength(prefix, prefixLength);
} else {
Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(name, nameLen));
}
}
|
| ︙ | ︙ | |||
5531 5532 5533 5534 5535 5536 5537 |
Tcl_Obj *result, /* Where to append matched items to. */
Tcl_Obj *pathPtr, /* Where we are looking. */
const char *pattern, /* What names we are looking for. */
Tcl_GlobTypeData *types) /* What types we are looking for. */
{
Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
int scnt, l;
| | < | | | < < | | | | | | | 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 |
Tcl_Obj *result, /* Where to append matched items to. */
Tcl_Obj *pathPtr, /* Where we are looking. */
const char *pattern, /* What names we are looking for. */
Tcl_GlobTypeData *types) /* What types we are looking for. */
{
Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
int scnt, l;
Tcl_Size len, strip = 0;
char *pat, *prefix, *path;
Tcl_DString dsPref, *prefixBuf = NULL;
int foundInHash, notDuplicate;
ZipEntry *z;
int wanted; /* TCL_GLOB_TYPE* */
if (!normPathPtr) {
return -1;
}
if (types) {
wanted = types->type;
if ((wanted & TCL_GLOB_TYPE_MOUNT) && (wanted != TCL_GLOB_TYPE_MOUNT)) {
ZIPFS_ERROR(interp,
"Internal error: TCL_GLOB_TYPE_MOUNT should not "
"be set in conjunction with other glob types.");
return TCL_ERROR;
}
if ((wanted & (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE |
TCL_GLOB_TYPE_MOUNT)) == 0) {
/* Not looking for files,dirs,mounts. zipfs cannot have others */
return TCL_OK;
}
wanted &= TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE | TCL_GLOB_TYPE_MOUNT;
} else {
wanted = TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE;
}
/*
* The prefix that gets prepended to results.
*/
prefix = TclGetString(pathPtr);
/*
* The (normalized) path we're searching.
*/
path = Tcl_GetStringFromObj(normPathPtr, &len);
Tcl_DStringInit(&dsPref);
if (!strcmp(prefix, path)) {
prefixBuf = NULL;
} else {
/*
* We need to strip the normalized prefix of the filenames and replace
* it with the official prefix that we were expecting to get.
*/
strip = len + 1;
TclDStringAppendObj(&dsPref, pathPtr);
TclDStringAppendLiteral(&dsPref, "/");
prefix = Tcl_DStringValue(&dsPref);
prefixBuf = &dsPref;
}
ReadLock();
/*
|
| ︙ | ︙ | |||
5662 5663 5664 5665 5666 5667 5668 |
Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS);
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (foundInHash) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | | | > | | | | | | | 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 |
Tcl_InitHashTable(&duplicates, TCL_STRING_KEYS);
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
if (foundInHash) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
z = (ZipEntry *) Tcl_GetHashValue(hPtr);
if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) ||
(wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) ||
(wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) {
if ((z->depth == scnt)
&& ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */
&& Tcl_StringCaseMatch(z->name, pat, 0)) {
Tcl_CreateHashEntry(&duplicates, z->name + strip,
¬Duplicate);
assert(notDuplicate);
AppendWithPrefix(result, prefixBuf, z->name + strip,
TCL_AUTO_LENGTH);
}
}
}
}
if (wanted & TCL_GLOB_TYPE_DIR) {
/*
* Also check paths that are ancestors of a mount. e.g. glob
* //zipfs:/a/? with mount at //zipfs:/a/b/c. Also have to be
* careful about duplicates, such as when another mount is
* //zipfs:/a/b/d
*/
Tcl_DString ds;
Tcl_DStringInit(&ds);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr);
if (Tcl_StringCaseMatch(zf->mountPoint, pat, 0)) {
const char *tail = zf->mountPoint + len;
if (*tail == '\0') {
continue;
}
const char *end = strchr(tail, '/');
Tcl_DStringAppend(&ds, zf->mountPoint + strip,
end ? (Tcl_Size)(end - zf->mountPoint) : TCL_AUTO_LENGTH);
const char *matchedPath = Tcl_DStringValue(&ds);
(void) Tcl_CreateHashEntry(
&duplicates, matchedPath, ¬Duplicate);
if (notDuplicate) {
AppendWithPrefix(result, prefixBuf, matchedPath,
Tcl_DStringLength(&ds));
}
Tcl_DStringFree(&ds);
}
}
}
Tcl_DeleteHashTable(&duplicates);
Tcl_Free(pat);
|
| ︙ | ︙ | |||
5751 5752 5753 5754 5755 5756 5757 |
* filenames, or NULL if no prefix is to be
* used. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int l;
Tcl_Size normLength;
| | | 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 |
* filenames, or NULL if no prefix is to be
* used. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int l;
Tcl_Size normLength;
const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength);
Tcl_Size len = normLength;
if (len < 1) {
/*
* Shouldn't happen. But "shouldn't"...
*/
|
| ︙ | ︙ | |||
5785 5786 5787 5788 5789 5790 5791 |
/*
* Enumerate the contents of the ZIP; it's mounted on the root.
* TODO - a holdover from androwish? Tcl does not allow mounting
* outside of the //zipfs:/ area.
*/
for (z = zf->topEnts; z; z = z->tnext) {
| | | | | 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 |
/*
* Enumerate the contents of the ZIP; it's mounted on the root.
* TODO - a holdover from androwish? Tcl does not allow mounting
* outside of the //zipfs:/ area.
*/
for (z = zf->topEnts; z; z = z->tnext) {
Tcl_Size lenz = ZipEntryNameLength(z);
if ((lenz > len + 1) && !strncmp(z->name, path, len)
&& (z->name[len] == '/')
&& ((int) CountSlashes(z->name) == l)
&& Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) {
AppendWithPrefix(result, prefix, z->name, lenz);
}
}
} else if ((zf->mountPointLen > len + 1)
&& !strncmp(zf->mountPoint, path, len)
&& (zf->mountPoint[len] == '/')
&& ((int) CountSlashes(zf->mountPoint) == l)
&& Tcl_StringCaseMatch(zf->mountPoint + len + 1,
pattern, 0)) {
/*
* Standard mount; append if it matches.
*/
|
| ︙ | ︙ | |||
5838 5839 5840 5841 5842 5843 5844 |
Tcl_Size len;
char *path;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
| | | | 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 |
Tcl_Size len;
char *path;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
path = Tcl_GetStringFromObj(pathPtr, &len);
/*
* Claim any path under ZIPFS_VOLUME as ours. This is both a necessary
* and sufficient condition as zipfs mounts at arbitrary paths are
* not permitted (unlike Androwish).
*/
return HasVolumePrefix(path) ? TCL_OK : -1;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSListVolumesProc --
*
|
| ︙ | ︙ | |||
5867 5868 5869 5870 5871 5872 5873 |
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSListVolumesProc(void)
{
| > | > | 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 |
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSListVolumesProc(void)
{
Tcl_Obj *volume;
TclNewLiteralStringObj(volume, ZIPFS_VOLUME);
return volume;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSFileAttrStringsProc --
*
|
| ︙ | ︙ | |||
5957 5958 5959 5960 5961 5962 5963 |
char *path;
ZipEntry *z;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
| | | | | > | | 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 |
char *path;
ZipEntry *z;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
path = Tcl_GetStringFromObj(pathPtr, &len);
ReadLock();
z = ZipFSLookup(path);
if (!z && !ContainsMountPoint(path, TCL_AUTO_LENGTH)) {
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
}
/* z == NULL for intermediate directories that are ancestors of mounts */
switch (index) {
case ZIP_ATTR_UNCOMPSIZE:
TclNewIntObj(*objPtrRef, z ? z->numBytes : 0);
break;
case ZIP_ATTR_COMPSIZE:
TclNewIntObj(*objPtrRef, z ? z->numCompressedBytes : 0);
break;
case ZIP_ATTR_OFFSET:
TclNewIntObj(*objPtrRef, z ? z->offset : 0);
break;
case ZIP_ATTR_MOUNT:
if (z) {
*objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint,
z->zipFilePtr->mountPointLen);
} else {
*objPtrRef = Tcl_NewStringObj("", 0);
}
break;
case ZIP_ATTR_ARCHIVE:
*objPtrRef = Tcl_NewStringObj(
z ? z->zipFilePtr->name : "", TCL_AUTO_LENGTH);
break;
case ZIP_ATTR_PERMISSIONS:
*objPtrRef = Tcl_NewStringObj("0o555", TCL_AUTO_LENGTH);
break;
case ZIP_ATTR_CRC:
TclNewIntObj(*objPtrRef, z ? z->crc32 : 0);
break;
default:
ZIPFS_ERROR(interp, "unknown attribute");
ZIPFS_ERROR_CODE(interp, "FILE_ATTR");
|
| ︙ | ︙ | |||
6050 6051 6052 6053 6054 6055 6056 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
| | | 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("zip", TCL_AUTO_LENGTH);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSLoadFile --
*
|
| ︙ | ︙ | |||
6218 6219 6220 6221 6222 6223 6224 |
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char findproc[] =
"namespace eval ::tcl::zipfs {}\n"
"proc ::tcl::zipfs::Find dir {\n"
" set result {}\n"
" if {[catch {\n"
| | > | | 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 |
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char findproc[] =
"namespace eval ::tcl::zipfs {}\n"
"proc ::tcl::zipfs::Find dir {\n"
" set result {}\n"
" if {[catch {\n"
" concat [glob -directory $dir -nocomplain *] "
"[glob -directory $dir -types hidden -nocomplain *]\n"
" } list]} {\n"
" return $result\n"
" }\n"
" foreach file $list {\n"
" if {[file tail $file] in {. ..}} {\n"
" continue\n"
" }\n"
" lappend result $file {*}[Find $file]\n"
|
| ︙ | ︙ | |||
6321 6322 6323 6324 6325 6326 6327 | #endif /* *------------------------------------------------------------------------ * * TclZipfsFinalize -- * | | | | | | | 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 |
#endif
/*
*------------------------------------------------------------------------
*
* TclZipfsFinalize --
*
* Frees all zipfs resources IRRESPECTIVE of open channels (there should
* not be any!) etc. To be called at process exit time (from
* Tcl_Finalize->TclFinalizeFilesystem)
*
* Results:
* None.
*
* Side effects:
* Frees up archives loaded into memory.
*
*------------------------------------------------------------------------
*/
void
TclZipfsFinalize(void)
{
WriteLock();
|
| ︙ | ︙ | |||
6450 6451 6452 6453 6454 6455 6456 | Tcl_DString ds; Tcl_DStringInit(&ds); archive = Tcl_WCharToUtfDString((*argvPtr)[1], TCL_INDEX_NONE, &ds); #else /* !_WIN32 */ archive = (*argvPtr)[1]; #endif /* _WIN32 */ | | | 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 |
Tcl_DString ds;
Tcl_DStringInit(&ds);
archive = Tcl_WCharToUtfDString((*argvPtr)[1], TCL_INDEX_NONE, &ds);
#else /* !_WIN32 */
archive = (*argvPtr)[1];
#endif /* _WIN32 */
if (!strcmp(archive, "install")) {
Tcl_Obj *vfsInitScript;
/*
* Run this now to ensure the file is present by the time Tcl_Main
* wants it.
*/
|
| ︙ | ︙ | |||
6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 |
*
* TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
*
* Dummy version when no ZLIB support available.
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_Mount(
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(const char *), /* Path to ZIP file to mount. */
TCL_UNUSED(const char *), /* Mount point path. */
| > > > > > > > > | < | < | < | | | 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 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 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 |
*
* TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount --
*
* Dummy version when no ZLIB support available.
*
*-------------------------------------------------------------------------
*/
static inline void
Unsupported(
Tcl_Interp *interp)
{
ZIPFS_ERROR(interp, "no zlib available");
ZIPFS_ERROR_CODE(interp, "NO_ZLIB");
}
int
TclZipfs_Mount(
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(const char *), /* Path to ZIP file to mount. */
TCL_UNUSED(const char *), /* Mount point path. */
TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if
* the ZIP is unprotected. */
{
Unsupported(interp);
return TCL_ERROR;
}
int
TclZipfs_MountBuffer(
Tcl_Interp *interp, /* Current interpreter. NULLable. */
TCL_UNUSED(const void *),
TCL_UNUSED(size_t),
TCL_UNUSED(const char *), /* Mount point path. */
TCL_UNUSED(int))
{
Unsupported(interp);
return TCL_ERROR;
}
int
TclZipfs_Unmount(
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(const char *)) /* Mount point path. */
{
Unsupported(interp);
return TCL_ERROR;
}
const char *
TclZipfs_AppHook(
TCL_UNUSED(int *), /*argcPtr*/
#ifdef _WIN32
TCL_UNUSED(WCHAR ***)) /* argvPtr */
#else /* !_WIN32 */
TCL_UNUSED(char ***)) /* Pointer to argv */
#endif /* _WIN32 */
{
return NULL;
}
Tcl_Obj *
TclZipfs_TclLibrary(void)
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2004-2005 Pascal Scheffers <pascal@scheffers.net> * Copyright © 2005 Unitas Software B.V. * Copyright © 2008-2012 Donal K. Fellows * * Parts written by Jean-Claude Wippler, as part of Tclkit, placed in the * public domain March 2003. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclZlib.c -- * * This file provides the interface to the Zlib library. */ #include "tclInt.h" #ifdef HAVE_ZLIB #include "zlib.h" #include "tclIO.h" /* * The version of the zlib "package" that this implements. Note that this |
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
"binary", "text"
};
if (TclDictGet(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
| | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
"binary", "text"
};
if (TclDictGet(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
valueStr = Tcl_GetStringFromObj(value, &length);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length,
TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT,
&state, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN - 1, NULL,
&len, NULL);
if (result != TCL_OK) {
if (interp) {
if (result == TCL_CONVERT_UNKNOWN) {
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
goto error;
}
if (TclDictGet(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
| | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
goto error;
}
if (TclDictGet(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
valueStr = Tcl_GetStringFromObj(value, &length);
result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length,
TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT,
&state, headerPtr->nativeFilenameBuf, MAXPATHLEN - 1, NULL,
&len, NULL);
if (result != TCL_OK) {
if (interp) {
if (result == TCL_CONVERT_UNKNOWN) {
|
| ︙ | ︙ | |||
3524 3525 3526 3527 3528 3529 3530 |
TclGetString(chanDataPtr->compDictObj));
} else {
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
if (chanDataPtr->compDictObj) {
Tcl_Size length;
| | | | 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 |
TclGetString(chanDataPtr->compDictObj));
} else {
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
if (chanDataPtr->compDictObj) {
Tcl_Size length;
const char *str = Tcl_GetStringFromObj(chanDataPtr->compDictObj,
&length);
Tcl_DStringAppend(dsPtr, str, length);
}
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
3770 3771 3772 3773 3774 3775 3776 |
if (compDictObj != NULL) {
chanDataPtr->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(chanDataPtr->compDictObj);
Tcl_GetBytesFromObj(NULL, chanDataPtr->compDictObj, (Tcl_Size *)NULL);
}
switch (format) {
| | | 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 |
if (compDictObj != NULL) {
chanDataPtr->compDictObj = Tcl_DuplicateObj(compDictObj);
Tcl_IncrRefCount(chanDataPtr->compDictObj);
Tcl_GetBytesFromObj(NULL, chanDataPtr->compDictObj, (Tcl_Size *)NULL);
}
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution of commands # and can be auto loaded themselves. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution of commands # and can be auto loaded themselves. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # auto_reset -- # # Destroy all cached information for auto-loading and auto-execution, so that # the information gets recomputed the next time it's needed. Also delete any # commands that are listed in the auto-load index. # |
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
set error [catch {
set f [open $file]
fconfigure $f -encoding utf-8 -eofchar \x1A
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
| | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
set error [catch {
set f [open $file]
fconfigure $f -encoding utf-8 -eofchar \x1A
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 |
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
| | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
# the file name that we know about (which will be a proper list, and so
# correctly quoted).
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
{set auto_index(%s) [list source [file join $dir %s]]%s} \
$name $filenameParts \n]
return
}
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
|
| ︙ | ︙ |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 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 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 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 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 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 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 4193 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 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 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 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 |
# Copyright © 2004-2007 Kevin B. Kenny
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# clock.tcl --
#
# This file implements the portions of the [clock] ensemble that are
# coded in Tcl. Refer to the users' manual to see the description of
# the [clock] command and its subcommands.
#
#
# We must have message catalogs that support the root locale, and we need
# access to the Registry on Windows systems.
uplevel \#0 {
package require msgcat 1.6
if { $::tcl_platform(platform) eq {windows} } {
if { [catch { package require registry 1.1 }] } {
variable NoRegistry {}
}
}
}
# Put the library directory into the namespace for the ensemble so that the
# library code can find message catalogs and time zone definition files.
variable LibDir [info library]
#----------------------------------------------------------------------
#
# clock --
#
# Manipulate times.
#
# The 'clock' command manipulates time. Refer to the user documentation for
# the available subcommands and what they do.
#
#----------------------------------------------------------------------
# Export the subcommands
namespace export format
namespace export clicks
namespace export microseconds
namespace export milliseconds
namespace export scan
namespace export seconds
namespace export add
# Import the message catalog commands that we use.
namespace import ::msgcat::mcload
namespace import ::msgcat::mclocale
proc mc {args} { tailcall ::msgcat::mcn [namespace current] {*}$args }
namespace import ::msgcat::mcpackagelocale
#----------------------------------------------------------------------
#
# Initialize --
#
# Finish initializing the 'clock' subsystem
#
# Results:
# None.
#
# Side effects:
# Namespace variable in the 'clock' subsystem are initialized.
#
# The 'Initialize' procedure initializes the namespace variables
# and root locale message catalog for the 'clock' subsystem. It is broken
# into a procedure rather than simply evaluated as a script so that it will be
# able to use local variables, avoiding the dangers of 'creative writing' as
# in Bug 1185933.
#
#----------------------------------------------------------------------
proc Initialize {} {
rename [namespace current]::Initialize {}
variable LibDir
# Define the Greenwich time zone
proc InitTZData {} {
variable TZData
array unset TZData
set TZData(:Etc/GMT) {
{-9223372036854775808 0 0 GMT}
}
set TZData(:GMT) $TZData(:Etc/GMT)
set TZData(:Etc/UTC) {
{-9223372036854775808 0 0 UTC}
}
set TZData(:UTC) $TZData(:Etc/UTC)
set TZData(:localtime) {}
}
InitTZData
mcpackagelocale set {}
::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs]
::msgcat::mcpackageconfig set unknowncmd ""
::msgcat::mcpackageconfig set changecmd ChangeCurrentLocale
# Define the message catalog for the root locale.
::msgcat::mcmset {} {
AM {am}
BCE {B.C.E.}
CE {C.E.}
DATE_FORMAT {%m/%d/%Y}
DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
DAYS_OF_WEEK_ABBREV {
Sun Mon Tue Wed Thu Fri Sat
}
DAYS_OF_WEEK_FULL {
Sunday Monday Tuesday Wednesday Thursday Friday Saturday
}
GREGORIAN_CHANGE_DATE 2299161
LOCALE_DATE_FORMAT {%m/%d/%Y}
LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
LOCALE_ERAS {}
LOCALE_NUMERALS {
00 01 02 03 04 05 06 07 08 09
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
}
LOCALE_TIME_FORMAT {%H:%M:%S}
LOCALE_YEAR_FORMAT {%EC%Ey}
MONTHS_ABBREV {
Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
}
MONTHS_FULL {
January February March
April May June
July August September
October November December
}
PM {pm}
TIME_FORMAT {%H:%M:%S}
TIME_FORMAT_12 {%I:%M:%S %P}
TIME_FORMAT_24 {%H:%M}
TIME_FORMAT_24_SECS {%H:%M:%S}
}
# Define a few Gregorian change dates for other locales. In most cases
# the change date follows a language, because a nation's colonies changed
# at the same time as the nation itself. In many cases, different
# national boundaries existed; the dominating rule is to follow the
# nation's capital.
# Italy, Spain, Portugal, Poland
::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
# France, Austria
::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
# For Belgium, we follow Southern Netherlands; Liege Diocese changed
# several weeks later.
::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
# Austria
::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
# Hungary
::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
# Germany, Norway, Denmark (Catholic Germany changed earlier)
::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032
::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
# Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at
# various times)
::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
# Protestant Switzerland (Catholic cantons changed earlier)
::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
# English speaking countries
::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
# Sweden (had several changes onto and off of the Gregorian calendar)
::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
# Russia
::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
# Romania (Transylvania changed earlier - perhaps de_RO should show the
# earlier date?)
::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
# Greece
::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
#------------------------------------------------------------------
#
# CONSTANTS
#
#------------------------------------------------------------------
# Paths at which binary time zone data for the Olson libraries are known
# to reside on various operating systems
variable ZoneinfoPaths {}
foreach path {
/usr/share/zoneinfo
/usr/share/lib/zoneinfo
/usr/lib/zoneinfo
/usr/local/etc/zoneinfo
} {
if { [file isdirectory $path] } {
lappend ZoneinfoPaths $path
}
}
# Define the directories for time zone data and message catalogs.
variable DataDir [file join $LibDir tzdata]
# Number of days in the months, in common years and leap years.
variable DaysInRomanMonthInCommonYear \
{ 31 28 31 30 31 30 31 31 30 31 30 31 }
variable DaysInRomanMonthInLeapYear \
{ 31 29 31 30 31 30 31 31 30 31 30 31 }
variable DaysInPriorMonthsInCommonYear [list 0]
variable DaysInPriorMonthsInLeapYear [list 0]
set i 0
foreach j $DaysInRomanMonthInCommonYear {
lappend DaysInPriorMonthsInCommonYear [incr i $j]
}
set i 0
foreach j $DaysInRomanMonthInLeapYear {
lappend DaysInPriorMonthsInLeapYear [incr i $j]
}
# Another epoch (Hi, Jeff!)
variable Roddenberry 1946
# Integer ranges
variable MINWIDE -9223372036854775808
variable MAXWIDE 9223372036854775807
# Day before Leap Day
variable FEB_28 58
# Translation table to map Windows TZI onto cities, so that the Olson
# rules can apply. In some cases the mapping is ambiguous, so it's wise
# to specify $::env(TCL_TZ) rather than simply depending on the system
# time zone.
# The keys are long lists of values obtained from the time zone
# information in the Registry. In order, the list elements are:
# Bias StandardBias DaylightBias
# StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
# StandardDate.wDay StandardDate.wHour StandardDate.wMinute
# StandardDate.wSecond StandardDate.wMilliseconds
# DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
# DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
# DaylightDate.wSecond DaylightDate.wMilliseconds
# The values are the names of time zones where those rules apply. There
# is considerable ambiguity in certain zones; an attempt has been made to
# make a reasonable guess, but this table needs to be taken with a grain
# of salt.
variable WinZoneInfo [dict create {*}{
{-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
{-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
{-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
{-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
{-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
{-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
{-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
{-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
{-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
{-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
{-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
{-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
{-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
{-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
{-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
:America/Santiago
{-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
{-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
{-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
{-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
{-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
{-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
{-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
{-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
{-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
{-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
{-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
{0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
{0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
{3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
{3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
{7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
{7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
:Africa/Cairo
{7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
{7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
{7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
{7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
{7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
{7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
:Asia/Beirut
{7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
{10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
{10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
{10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
{12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
{14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
{14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
{14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
{16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
{18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi
{18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg
{19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta
{20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu
{21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka
{21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk
{23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon
{25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok
{25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk
{28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing
{28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk
{32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo
{32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk
{34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide
{34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin
{36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane
{36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok
{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart
{36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
{39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
{43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
{43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
}]
# Groups of fields that specify the date, priorities, and code bursts that
# determine Julian Day Number given those groups. The code in [clock
# scan] will choose the highest priority (lowest numbered) set of fields
# that determines the date.
variable DateParseActions {
{ seconds } 0 {}
{ julianDay } 1 {}
{ era century yearOfCentury month dayOfMonth } 2 {
dict set date year [expr { 100 * [dict get $date century]
+ [dict get $date yearOfCentury] }]
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
$changeover]
}
{ era century yearOfCentury dayOfYear } 2 {
dict set date year [expr { 100 * [dict get $date century]
+ [dict get $date yearOfCentury] }]
set date [GetJulianDayFromEraYearDay $date[set date {}] \
$changeover]
}
{ century yearOfCentury month dayOfMonth } 3 {
dict set date era CE
dict set date year [expr { 100 * [dict get $date century]
+ [dict get $date yearOfCentury] }]
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
$changeover]
}
{ century yearOfCentury dayOfYear } 3 {
dict set date era CE
dict set date year [expr { 100 * [dict get $date century]
+ [dict get $date yearOfCentury] }]
set date [GetJulianDayFromEraYearDay $date[set date {}] \
$changeover]
}
{ iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
dict set date era CE
dict set date iso8601Year \
[expr { 100 * [dict get $date iso8601Century]
+ [dict get $date iso8601YearOfCentury] }]
set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
$changeover]
}
{ yearOfCentury month dayOfMonth } 4 {
set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
dict set date era CE
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
$changeover]
}
{ yearOfCentury dayOfYear } 4 {
set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
dict set date era CE
set date [GetJulianDayFromEraYearDay $date[set date {}] \
$changeover]
}
{ iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
set date [InterpretTwoDigitYear \
$date[set date {}] $baseTime \
iso8601YearOfCentury iso8601Year]
dict set date era CE
set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
$changeover]
}
{ month dayOfMonth } 5 {
set date [AssignBaseYear $date[set date {}] \
$baseTime $timeZone $changeover]
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
$changeover]
}
{ dayOfYear } 5 {
set date [AssignBaseYear $date[set date {}] \
$baseTime $timeZone $changeover]
set date [GetJulianDayFromEraYearDay $date[set date {}] \
$changeover]
}
{ iso8601Week dayOfWeek } 5 {
set date [AssignBaseIso8601Year $date[set date {}] \
$baseTime $timeZone $changeover]
set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
$changeover]
}
{ dayOfMonth } 6 {
set date [AssignBaseMonth $date[set date {}] \
$baseTime $timeZone $changeover]
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
$changeover]
}
{ dayOfWeek } 7 {
set date [AssignBaseWeek $date[set date {}] \
$baseTime $timeZone $changeover]
set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
$changeover]
}
{} 8 {
set date [AssignBaseJulianDay $date[set date {}] \
$baseTime $timeZone $changeover]
}
}
# Groups of fields that specify time of day, priorities, and code that
# processes them
variable TimeParseActions {
seconds 1 {}
{ hourAMPM minute second amPmIndicator } 2 {
dict set date secondOfDay [InterpretHMSP $date]
}
{ hour minute second } 2 {
dict set date secondOfDay [InterpretHMS $date]
}
{ hourAMPM minute amPmIndicator } 3 {
dict set date second 0
dict set date secondOfDay [InterpretHMSP $date]
}
{ hour minute } 3 {
dict set date second 0
dict set date secondOfDay [InterpretHMS $date]
}
{ hourAMPM amPmIndicator } 4 {
dict set date minute 0
dict set date second 0
dict set date secondOfDay [InterpretHMSP $date]
}
{ hour } 4 {
dict set date minute 0
dict set date second 0
dict set date secondOfDay [InterpretHMS $date]
}
{ } 5 {
dict set date secondOfDay 0
}
}
# Legacy time zones, used primarily for parsing RFC822 dates.
variable LegacyTimeZone [dict create \
gmt +0000 \
ut +0000 \
utc +0000 \
bst +0100 \
wet +0000 \
wat -0100 \
at -0200 \
nft -0330 \
nst -0330 \
ndt -0230 \
ast -0400 \
adt -0300 \
est -0500 \
edt -0400 \
cst -0600 \
cdt -0500 \
mst -0700 \
mdt -0600 \
pst -0800 \
pdt -0700 \
yst -0900 \
ydt -0800 \
akst -0900 \
akdt -0800 \
hst -1000 \
hdt -0900 \
cat -1000 \
ahst -1000 \
nt -1100 \
idlw -1200 \
cet +0100 \
cest +0200 \
met +0100 \
mewt +0100 \
mest +0200 \
swt +0100 \
sst +0200 \
fwt +0100 \
fst +0200 \
eet +0200 \
eest +0300 \
bt +0300 \
it +0330 \
zp4 +0400 \
zp5 +0500 \
ist +0530 \
zp6 +0600 \
wast +0700 \
wadt +0800 \
jt +0730 \
cct +0800 \
jst +0900 \
kst +0900 \
cast +0930 \
jdt +1000 \
kdt +1000 \
cadt +1030 \
east +1000 \
eadt +1030 \
gst +1000 \
nzt +1200 \
nzst +1200 \
nzdt +1300 \
idle +1200 \
a +0100 \
b +0200 \
c +0300 \
d +0400 \
e +0500 \
f +0600 \
g +0700 \
h +0800 \
i +0900 \
k +1000 \
l +1100 \
m +1200 \
n -0100 \
o -0200 \
p -0300 \
q -0400 \
r -0500 \
s -0600 \
t -0700 \
u -0800 \
v -0900 \
w -1000 \
x -1100 \
y -1200 \
z +0000 \
]
# Caches
variable LocaleNumeralCache {}; # Dictionary whose keys are locale
# names and whose values are pairs
# comprising regexes matching numerals
# in the given locales and dictionaries
# mapping the numerals to their numeric
# values.
# variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
# it contains the value of the
# system time zone, as determined from
# the environment.
variable TimeZoneBad {}; # Dictionary whose keys are time zone
# names and whose values are 1 if
# the time zone is unknown and 0
# if it is known.
variable TZData; # Array whose keys are time zone names
# and whose values are lists of quads
# comprising start time, UTC offset,
# Daylight Saving Time indicator, and
# time zone abbreviation.
variable FormatProc; # Array mapping format group
# and locale to the name of a procedure
# that renders the given format
}
Initialize
#----------------------------------------------------------------------
#
# clock format --
#
# Formats a count of seconds since the Posix Epoch as a time of day.
#
# The 'clock format' command formats times of day for output. Refer to the
# user documentation to see what it does.
#
#----------------------------------------------------------------------
proc format { args } {
variable FormatProc
variable TZData
lassign [ParseFormatArgs {*}$args] format locale timezone
set locale [string tolower $locale]
set clockval [lindex $args 0]
# Get the data for time changes in the given zone
if {$timezone eq ""} {
set timezone [GetSystemTimeZone]
}
if {![info exists TZData($timezone)]} {
if {[catch {SetupTimeZone $timezone} retval opts]} {
dict unset opts -errorinfo
return -options $opts $retval
}
}
# Build a procedure to format the result. Cache the built procedure's name
# in the 'FormatProc' array to avoid losing its internal representation,
# which contains the name resolution.
set procName formatproc'$format'$locale
set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
if {[info exists FormatProc($procName)]} {
set procName $FormatProc($procName)
} else {
set FormatProc($procName) \
[ParseClockFormatFormat $procName $format $locale]
}
return [$procName $clockval $timezone]
}
#----------------------------------------------------------------------
#
# ParseClockFormatFormat --
#
# Builds and caches a procedure that formats a time value.
#
# Parameters:
# format -- Format string to use
# locale -- Locale in which the format string is to be interpreted
#
# Results:
# Returns the name of the newly-built procedure.
#
#----------------------------------------------------------------------
proc ParseClockFormatFormat {procName format locale} {
if {[namespace which $procName] ne {}} {
return $procName
}
# Map away the locale-dependent composite format groups
EnterLocale $locale
# Change locale if a fresh locale has been given on the command line.
try {
return [ParseClockFormatFormat2 $format $locale $procName]
} trap CLOCK {result opts} {
dict unset opts -errorinfo
return -options $opts $result
}
}
proc ParseClockFormatFormat2 {format locale procName} {
set didLocaleEra 0
set didLocaleNumerals 0
set preFormatCode \
[string map [list @GREGORIAN_CHANGE_DATE@ \
[mc GREGORIAN_CHANGE_DATE]] \
{
variable TZData
set date [GetDateFields $clockval \
$TZData($timezone) \
@GREGORIAN_CHANGE_DATE@]
}]
set formatString {}
set substituents {}
set state {}
set format [LocalizeFormat $locale $format]
foreach char [split $format {}] {
switch -exact -- $state {
{} {
if { [string equal % $char] } {
set state percent
} else {
append formatString $char
}
}
percent { # Character following a '%' character
set state {}
switch -exact -- $char {
% { # A literal character, '%'
append formatString %%
}
a { # Day of week, abbreviated
append formatString %s
append substituents \
[string map \
[list @DAYS_OF_WEEK_ABBREV@ \
[list [mc DAYS_OF_WEEK_ABBREV]]] \
{ [lindex @DAYS_OF_WEEK_ABBREV@ \
[expr {[dict get $date dayOfWeek] \
% 7}]]}]
}
A { # Day of week, spelt out.
append formatString %s
append substituents \
[string map \
[list @DAYS_OF_WEEK_FULL@ \
[list [mc DAYS_OF_WEEK_FULL]]] \
{ [lindex @DAYS_OF_WEEK_FULL@ \
[expr {[dict get $date dayOfWeek] \
% 7}]]}]
}
b - h { # Name of month, abbreviated.
append formatString %s
append substituents \
[string map \
[list @MONTHS_ABBREV@ \
[list [mc MONTHS_ABBREV]]] \
{ [lindex @MONTHS_ABBREV@ \
[expr {[dict get $date month]-1}]]}]
}
B { # Name of month, spelt out
append formatString %s
append substituents \
[string map \
[list @MONTHS_FULL@ \
[list [mc MONTHS_FULL]]] \
{ [lindex @MONTHS_FULL@ \
[expr {[dict get $date month]-1}]]}]
}
C { # Century number
append formatString %02d
append substituents \
{ [expr {[dict get $date year] / 100}]}
}
d { # Day of month, with leading zero
append formatString %02d
append substituents { [dict get $date dayOfMonth]}
}
e { # Day of month, without leading zero
append formatString %2d
append substituents { [dict get $date dayOfMonth]}
}
E { # Format group in a locale-dependent
# alternative era
set state percentE
if {!$didLocaleEra} {
append preFormatCode \
[string map \
[list @LOCALE_ERAS@ \
[list [mc LOCALE_ERAS]]] \
{
set date [GetLocaleEra \
$date[set date {}] \
@LOCALE_ERAS@]}] \n
set didLocaleEra 1
}
if {!$didLocaleNumerals} {
append preFormatCode \
[list set localeNumerals \
[mc LOCALE_NUMERALS]] \n
set didLocaleNumerals 1
}
}
g { # Two-digit year relative to ISO8601
# week number
append formatString %02d
append substituents \
{ [expr { [dict get $date iso8601Year] % 100 }]}
}
G { # Four-digit year relative to ISO8601
# week number
append formatString %02d
append substituents { [dict get $date iso8601Year]}
}
H { # Hour in the 24-hour day, leading zero
append formatString %02d
append substituents \
{ [expr { [dict get $date localSeconds] \
/ 3600 % 24}]}
}
I { # Hour AM/PM, with leading zero
append formatString %02d
append substituents \
{ [expr { ( ( ( [dict get $date localSeconds] \
% 86400 ) \
+ 86400 \
- 3600 ) \
/ 3600 ) \
% 12 + 1 }] }
}
j { # Day of year (001-366)
append formatString %03d
append substituents { [dict get $date dayOfYear]}
}
J { # Julian Day Number
append formatString %07ld
append substituents { [dict get $date julianDay]}
}
k { # Hour (0-23), no leading zero
append formatString %2d
append substituents \
{ [expr { [dict get $date localSeconds]
/ 3600
% 24 }]}
}
l { # Hour (12-11), no leading zero
append formatString %2d
append substituents \
{ [expr { ( ( ( [dict get $date localSeconds]
% 86400 )
+ 86400
- 3600 )
/ 3600 )
% 12 + 1 }]}
}
m { # Month number, leading zero
append formatString %02d
append substituents { [dict get $date month]}
}
M { # Minute of the hour, leading zero
append formatString %02d
append substituents \
{ [expr { [dict get $date localSeconds]
/ 60
% 60 }]}
}
n { # A literal newline
append formatString \n
}
N { # Month number, no leading zero
append formatString %2d
append substituents { [dict get $date month]}
}
O { # A format group in the locale's
# alternative numerals
set state percentO
if {!$didLocaleNumerals} {
append preFormatCode \
[list set localeNumerals \
[mc LOCALE_NUMERALS]] \n
set didLocaleNumerals 1
}
}
p { # Localized 'AM' or 'PM' indicator
# converted to uppercase
append formatString %s
append preFormatCode \
[list set AM [string toupper [mc AM]]] \n \
[list set PM [string toupper [mc PM]]] \n
append substituents \
{ [expr {(([dict get $date localSeconds]
% 86400) < 43200) ?
$AM : $PM}]}
}
P { # Localized 'AM' or 'PM' indicator
append formatString %s
append preFormatCode \
[list set am [mc AM]] \n \
[list set pm [mc PM]] \n
append substituents \
{ [expr {(([dict get $date localSeconds]
% 86400) < 43200) ?
$am : $pm}]}
}
Q { # Hi, Jeff!
append formatString %s
append substituents { [FormatStarDate $date]}
}
s { # Seconds from the Posix Epoch
append formatString %s
append substituents { [dict get $date seconds]}
}
S { # Second of the minute, with
# leading zero
append formatString %02d
append substituents \
{ [expr { [dict get $date localSeconds]
% 60 }]}
}
t { # A literal tab character
append formatString \t
}
u { # Day of the week (1-Monday, 7-Sunday)
append formatString %1d
append substituents { [dict get $date dayOfWeek]}
}
U { # Week of the year (00-53). The
# first Sunday of the year is the
# first day of week 01
append formatString %02d
append preFormatCode {
set dow [dict get $date dayOfWeek]
if { $dow == 7 } {
set dow 0
}
incr dow
set UweekNumber \
[expr { ( [dict get $date dayOfYear]
- $dow + 7 )
/ 7 }]
}
append substituents { $UweekNumber}
}
V { # The ISO8601 week number
append formatString %02d
append substituents { [dict get $date iso8601Week]}
}
w { # Day of the week (0-Sunday,
# 6-Saturday)
append formatString %1d
append substituents \
{ [expr { [dict get $date dayOfWeek] % 7 }]}
}
W { # Week of the year (00-53). The first
# Monday of the year is the first day
# of week 01.
append preFormatCode {
set WweekNumber \
[expr { ( [dict get $date dayOfYear]
- [dict get $date dayOfWeek]
+ 7 )
/ 7 }]
}
append formatString %02d
append substituents { $WweekNumber}
}
y { # The two-digit year of the century
append formatString %02d
append substituents \
{ [expr { [dict get $date year] % 100 }]}
}
Y { # The four-digit year
append formatString %04d
append substituents { [dict get $date year]}
}
z { # The time zone as hours and minutes
# east (+) or west (-) of Greenwich
append formatString %s
append substituents { [FormatNumericTimeZone \
[dict get $date tzOffset]]}
}
Z { # The name of the time zone
append formatString %s
append substituents { [dict get $date tzName]}
}
% { # A literal percent character
append formatString %%
}
default { # An unknown escape sequence
append formatString %% $char
}
}
}
percentE { # Character following %E
set state {}
switch -exact -- $char {
E {
append formatString %s
append substituents { } \
[string map \
[list @BCE@ [list [mc BCE]] \
@CE@ [list [mc CE]]] \
{[dict get {BCE @BCE@ CE @CE@} \
[dict get $date era]]}]
}
C { # Locale-dependent era
append formatString %s
append substituents { [dict get $date localeEra]}
}
y { # Locale-dependent year of the era
append preFormatCode {
set y [dict get $date localeYear]
if { $y >= 0 && $y < 100 } {
set Eyear [lindex $localeNumerals $y]
} else {
set Eyear $y
}
}
append formatString %s
append substituents { $Eyear}
}
default { # Unknown %E format group
append formatString %%E $char
}
}
}
percentO { # Character following %O
set state {}
switch -exact -- $char {
d - e { # Day of the month in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[dict get $date dayOfMonth]]}
}
H - k { # Hour of the day in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { [dict get $date localSeconds]
/ 3600
% 24 }]]}
}
I - l { # Hour (12-11) AM/PM in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { ( ( ( [dict get $date localSeconds]
% 86400 )
+ 86400
- 3600 )
/ 3600 )
% 12 + 1 }]]}
}
m { # Month number in alternative numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals [dict get $date month]]}
}
M { # Minute of the hour in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { [dict get $date localSeconds]
/ 60
% 60 }]]}
}
S { # Second of the minute in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { [dict get $date localSeconds]
% 60 }]]}
}
u { # Day of the week (Monday=1,Sunday=7)
# in alternative numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[dict get $date dayOfWeek]]}
}
w { # Day of the week (Sunday=0,Saturday=6)
# in alternative numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { [dict get $date dayOfWeek] % 7 }]]}
}
y { # Year of the century in alternative
# numerals
append formatString %s
append substituents \
{ [lindex $localeNumerals \
[expr { [dict get $date year] % 100 }]]}
}
default { # Unknown format group
append formatString %%O $char
}
}
}
}
}
# Clean up any improperly terminated groups
switch -exact -- $state {
percent {
append formatString %%
}
percentE {
append retval %%E
}
percentO {
append retval %%O
}
}
proc $procName {clockval timezone} "
$preFormatCode
return \[::format [list $formatString] $substituents\]
"
# puts [list $procName [info args $procName] [info body $procName]]
return $procName
}
#----------------------------------------------------------------------
#
# clock scan --
#
# Inputs a count of seconds since the Posix Epoch as a time of day.
#
# The 'clock scan' command scans times of day on input. Refer to the user
# documentation to see what it does.
#
#----------------------------------------------------------------------
proc scan { args } {
set format {}
# Check the count of args
if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
set cmdName "clock scan"
return -code error \
-errorcode [list CLOCK wrongNumArgs] \
"wrong \# args: should be\
\"$cmdName string\
?-base seconds?\
?-format string? ?-gmt boolean?\
?-locale LOCALE? ?-timezone ZONE?\""
}
# Set defaults
set base [clock seconds]
set string [lindex $args 0]
set format {}
set gmt 0
set locale c
set timezone [GetSystemTimeZone]
# Pick up command line options.
foreach { flag value } [lreplace $args 0 0] {
switch -exact -- $flag {
-b - -ba - -bas - -base {
set base $value
}
-f - -fo - -for - -form - -forma - -format {
set saw(-format) {}
set format $value
}
-g - -gm - -gmt {
set saw(-gmt) {}
set gmt $value
}
-l - -lo - -loc - -loca - -local - -locale {
set saw(-locale) {}
set locale [string tolower $value]
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
set saw(-timezone) {}
set timezone $value
}
default {
return -code error \
-errorcode [list CLOCK badOption $flag] \
"bad option \"$flag\":\
must be -base, -format, -gmt, -locale, or -timezone"
}
}
}
# Check options for validity
if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
return -code error \
-errorcode [list CLOCK gmtWithTimezone] \
"cannot use -gmt and -timezone in same call"
}
if { [catch { expr { wide($base) } } result] } {
return -code error "expected integer but got \"$base\""
}
if { ![string is boolean -strict $gmt] } {
return -code error "expected boolean value but got \"$gmt\""
} elseif { $gmt } {
set timezone :GMT
}
if { ![info exists saw(-format)] } {
# Perhaps someday we'll localize the legacy code. Right now, it's not
# localized.
if { [info exists saw(-locale)] } {
return -code error \
-errorcode [list CLOCK flagWithLegacyFormat] \
"legacy \[clock scan\] does not support -locale"
}
return [FreeScan $string $base $timezone $locale]
}
# Change locale if a fresh locale has been given on the command line.
EnterLocale $locale
try {
# Map away the locale-dependent composite format groups
set scanner [ParseClockScanFormat $format $locale]
return [$scanner $string $base $timezone]
} trap CLOCK {result opts} {
# Conceal location of generation of expected errors
dict unset opts -errorinfo
return -options $opts $result
}
}
#----------------------------------------------------------------------
#
# FreeScan --
#
# Scans a time in free format
#
# Parameters:
# string - String containing the time to scan
# base - Base time, expressed in seconds from the Epoch
# timezone - Default time zone in which the time will be expressed
# locale - (Unused) Name of the locale where the time will be scanned.
#
# Results:
# Returns the date and time extracted from the string in seconds from
# the epoch
#
#----------------------------------------------------------------------
proc FreeScan { string base timezone locale } {
variable TZData
# Get the data for time changes in the given zone
try {
SetupTimeZone $timezone
} on error {retval opts} {
dict unset opts -errorinfo
return -options $opts $retval
}
# Extract year, month and day from the base time for the parser to use as
# defaults
set date [GetDateFields $base $TZData($timezone) 2361222]
dict set date secondOfDay [expr {
[dict get $date localSeconds] % 86400
}]
# Parse the date. The parser will return a list comprising date, time,
# time zone, relative month/day/seconds, relative weekday, ordinal month.
try {
set scanned [Oldscan $string \
[dict get $date year] \
[dict get $date month] \
[dict get $date dayOfMonth]]
lassign $scanned \
parseDate parseTime parseZone parseRel \
parseWeekday parseOrdinalMonth
} on error message {
return -code error \
"unable to convert date-time string \"$string\": $message"
}
# If the caller supplied a date in the string, update the 'date' dict with
# the value. If the caller didn't specify a time with the date, default to
# midnight.
if { [llength $parseDate] > 0 } {
lassign $parseDate y m d
if { $y < 100 } {
if { $y >= 39 } {
incr y 1900
} else {
incr y 2000
}
}
dict set date era CE
dict set date year $y
dict set date month $m
dict set date dayOfMonth $d
if { $parseTime eq {} } {
set parseTime 0
}
}
# If the caller supplied a time zone in the string, it comes back as a
# two-element list; the first element is the number of minutes east of
# Greenwich, and the second is a Daylight Saving Time indicator (1 == yes,
# 0 == no, -1 == unknown). We make it into a time zone indicator of
# +-hhmm.
if { [llength $parseZone] > 0 } {
lassign $parseZone minEast dstFlag
set timezone [FormatNumericTimeZone \
[expr { 60 * $minEast + 3600 * $dstFlag }]]
SetupTimeZone $timezone
}
dict set date tzName $timezone
# Assemble date, time, zone into seconds-from-epoch
set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
if { $parseTime ne {} } {
dict set date secondOfDay $parseTime
} elseif { [llength $parseWeekday] != 0
|| [llength $parseOrdinalMonth] != 0
|| ( [llength $parseRel] != 0
&& ( [lindex $parseRel 0] != 0
|| [lindex $parseRel 1] != 0 ) ) } {
dict set date secondOfDay 0
}
dict set date localSeconds [expr {
-210866803200
+ ( 86400 * wide([dict get $date julianDay]) )
+ [dict get $date secondOfDay]
}]
dict set date tzName $timezone
set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
set seconds [dict get $date seconds]
# Do relative times
if { [llength $parseRel] > 0 } {
lassign $parseRel relMonth relDay relSecond
set seconds [add $seconds \
$relMonth months $relDay days $relSecond seconds \
-timezone $timezone -locale $locale]
}
# Do relative weekday
if { [llength $parseWeekday] > 0 } {
lassign $parseWeekday dayOrdinal dayOfWeek
set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
dict set date2 era CE
set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr {
[dict get $date2 julianDay] + 6
}]]
incr jdwkday [expr { 7 * $dayOrdinal }]
if { $dayOrdinal > 0 } {
incr jdwkday -7
}
dict set date2 secondOfDay \
[expr { [dict get $date2 localSeconds] % 86400 }]
dict set date2 julianDay $jdwkday
dict set date2 localSeconds [expr {
-210866803200
+ ( 86400 * wide([dict get $date2 julianDay]) )
+ [dict get $date secondOfDay]
}]
dict set date2 tzName $timezone
set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
2361222]
set seconds [dict get $date2 seconds]
}
# Do relative month
if { [llength $parseOrdinalMonth] > 0 } {
lassign $parseOrdinalMonth monthOrdinal monthNumber
if { $monthOrdinal > 0 } {
set monthDiff [expr { $monthNumber - [dict get $date month] }]
if { $monthDiff <= 0 } {
incr monthDiff 12
}
incr monthOrdinal -1
} else {
set monthDiff [expr { [dict get $date month] - $monthNumber }]
if { $monthDiff >= 0 } {
incr monthDiff -12
}
incr monthOrdinal
}
set seconds [add $seconds $monthOrdinal years $monthDiff months \
-timezone $timezone -locale $locale]
}
return $seconds
}
#----------------------------------------------------------------------
#
# ParseClockScanFormat --
#
# Parses a format string given to [clock scan -format]
#
# Parameters:
# formatString - The format being parsed
# locale - The current locale
#
# Results:
# Constructs and returns a procedure that accepts the string being
# scanned, the base time, and the time zone. The procedure will either
# return the scanned time or else throw an error that should be rethrown
# to the caller of [clock scan]
#
# Side effects:
# The given procedure is defined in the current namespace. Scan
# procedures are not deleted once installed.
#
# Why do we parse dates by defining a procedure to parse them? The reason is
# that by doing so, we have one convenient place to cache all the information:
# the regular expressions that match the patterns (which will be compiled),
# the code that assembles the date information, everything lands in one place.
# In this way, when a given format is reused at run time, all the information
# of how to apply it is available in a single place.
#
#----------------------------------------------------------------------
proc ParseClockScanFormat {formatString locale} {
# Check whether the format has been parsed previously, and return the
# existing recognizer if it has.
set procName scanproc'$formatString'$locale
set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
if { [namespace which $procName] != {} } {
return $procName
}
variable DateParseActions
variable TimeParseActions
# Localize the %x, %X, etc. groups
set formatString [LocalizeFormat $locale $formatString]
# Condense whitespace
regsub -all {[[:space:]]+} $formatString { } formatString
# Walk through the groups of the format string. In this loop, we
# accumulate:
# - a regular expression that matches the string,
# - the count of capturing brackets in the regexp
# - a set of code that post-processes the fields captured by the regexp,
# - a dictionary whose keys are the names of fields that are present
# in the format string.
set re {^[[:space:]]*}
set captureCount 0
set postcode {}
set fieldSet [dict create]
set fieldCount 0
set postSep {}
set state {}
foreach c [split $formatString {}] {
switch -exact -- $state {
{} {
if { $c eq "%" } {
set state %
} elseif { $c eq " " } {
append re {[[:space:]]+}
} else {
if { ! [string is alnum $c] } {
append re "\\"
}
append re $c
}
}
% {
set state {}
switch -exact -- $c {
% {
append re %
}
{ } {
append re "\[\[:space:\]\]*"
}
a - A { # Day of week, in words
set l {}
foreach \
i {7 1 2 3 4 5 6} \
abr [mc DAYS_OF_WEEK_ABBREV] \
full [mc DAYS_OF_WEEK_FULL] {
dict set l [string tolower $abr] $i
dict set l [string tolower $full] $i
incr i
}
lassign [UniquePrefixRegexp $l] regex lookup
append re ( $regex )
dict set fieldSet dayOfWeek [incr fieldCount]
append postcode "dict set date dayOfWeek \[" \
"dict get " [list $lookup] " " \
\[ {string tolower $field} [incr captureCount] \] \
"\]\n"
}
b - B - h { # Name of month
set i 0
set l {}
foreach \
abr [mc MONTHS_ABBREV] \
full [mc MONTHS_FULL] {
incr i
dict set l [string tolower $abr] $i
dict set l [string tolower $full] $i
}
lassign [UniquePrefixRegexp $l] regex lookup
append re ( $regex )
dict set fieldSet month [incr fieldCount]
append postcode "dict set date month \[" \
"dict get " [list $lookup] \
" " \[ {string tolower $field} \
[incr captureCount] \] \
"\]\n"
}
C { # Gregorian century
append re \\s*(\\d\\d?)
dict set fieldSet century [incr fieldCount]
append postcode "dict set date century \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
d - e { # Day of month
append re \\s*(\\d\\d?)
dict set fieldSet dayOfMonth [incr fieldCount]
append postcode "dict set date dayOfMonth \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
E { # Prefix for locale-specific codes
set state %E
}
g { # ISO8601 2-digit year
append re \\s*(\\d\\d)
dict set fieldSet iso8601YearOfCentury \
[incr fieldCount]
append postcode \
"dict set date iso8601YearOfCentury \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
G { # ISO8601 4-digit year
append re \\s*(\\d\\d)(\\d\\d)
dict set fieldSet iso8601Century [incr fieldCount]
dict set fieldSet iso8601YearOfCentury \
[incr fieldCount]
append postcode \
"dict set date iso8601Century \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n" \
"dict set date iso8601YearOfCentury \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
H - k { # Hour of day
append re \\s*(\\d\\d?)
dict set fieldSet hour [incr fieldCount]
append postcode "dict set date hour \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
I - l { # Hour, AM/PM
append re \\s*(\\d\\d?)
dict set fieldSet hourAMPM [incr fieldCount]
append postcode "dict set date hourAMPM \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
j { # Day of year
append re \\s*(\\d\\d?\\d?)
dict set fieldSet dayOfYear [incr fieldCount]
append postcode "dict set date dayOfYear \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
J { # Julian Day Number
append re \\s*(\\d+)
dict set fieldSet julianDay [incr fieldCount]
append postcode "dict set date julianDay \[" \
"::scan \$field" [incr captureCount] " %ld" \
"\]\n"
}
m - N { # Month number
append re \\s*(\\d\\d?)
dict set fieldSet month [incr fieldCount]
append postcode "dict set date month \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
M { # Minute
append re \\s*(\\d\\d?)
dict set fieldSet minute [incr fieldCount]
append postcode "dict set date minute \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
n { # Literal newline
append re \\n
}
O { # Prefix for locale numerics
set state %O
}
p - P { # AM/PM indicator
set l [list [string tolower [mc AM]] 0 \
[string tolower [mc PM]] 1]
lassign [UniquePrefixRegexp $l] regex lookup
append re ( $regex )
dict set fieldSet amPmIndicator [incr fieldCount]
append postcode "dict set date amPmIndicator \[" \
"dict get " [list $lookup] " \[string tolower " \
"\$field" \
[incr captureCount] \
"\]\]\n"
}
Q { # Hi, Jeff!
append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
incr captureCount
dict set fieldSet seconds [incr fieldCount]
append postcode {dict set date seconds } \[ \
{ParseStarDate $field} [incr captureCount] \
{ $field} [incr captureCount] \
{ $field} [incr captureCount] \
\] \n
}
s { # Seconds from Posix Epoch
# This next case is insanely difficult, because it's
# problematic to determine whether the field is
# actually within the range of a wide integer.
append re {\s*([-+]?\d+)}
dict set fieldSet seconds [incr fieldCount]
append postcode {dict set date seconds } \[ \
{ScanWide $field} [incr captureCount] \] \n
}
S { # Second
append re \\s*(\\d\\d?)
dict set fieldSet second [incr fieldCount]
append postcode "dict set date second \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
t { # Literal tab character
append re \\t
}
u - w { # Day number within week, 0 or 7 == Sun
# 1=Mon, 6=Sat
append re \\s*(\\d)
dict set fieldSet dayOfWeek [incr fieldCount]
append postcode {::scan $field} [incr captureCount] \
{ %d dow} \n \
{
if { $dow == 0 } {
set dow 7
} elseif { $dow > 7 } {
return -code error \
-errorcode [list CLOCK badDayOfWeek] \
"day of week is greater than 7"
}
dict set date dayOfWeek $dow
}
}
U { # Week of year. The first Sunday of
# the year is the first day of week
# 01. No scan rule uses this group.
append re \\s*\\d\\d?
}
V { # Week of ISO8601 year
append re \\s*(\\d\\d?)
dict set fieldSet iso8601Week [incr fieldCount]
append postcode "dict set date iso8601Week \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
W { # Week of the year (00-53). The first
# Monday of the year is the first day
# of week 01. No scan rule uses this
# group.
append re \\s*\\d\\d?
}
y { # Two-digit Gregorian year
append re \\s*(\\d\\d?)
dict set fieldSet yearOfCentury [incr fieldCount]
append postcode "dict set date yearOfCentury \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
Y { # 4-digit Gregorian year
append re \\s*(\\d\\d)(\\d\\d)
dict set fieldSet century [incr fieldCount]
dict set fieldSet yearOfCentury [incr fieldCount]
append postcode \
"dict set date century \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n" \
"dict set date yearOfCentury \[" \
"::scan \$field" [incr captureCount] " %d" \
"\]\n"
}
z - Z { # Time zone name
append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)|([[:alnum:]]{1,4}))}
dict set fieldSet tzName [incr fieldCount]
append postcode \
{if } \{ { $field} [incr captureCount] \
{ ne "" } \} { } \{ \n \
{dict set date tzName $field} \
$captureCount \n \
\} { else } \{ \n \
{dict set date tzName } \[ \
{ConvertLegacyTimeZone $field} \
[incr captureCount] \] \n \
\} \n \
}
% { # Literal percent character
append re %
}
default {
append re %
if { ! [string is alnum $c] } {
append re \\
}
append re $c
}
}
}
%E {
switch -exact -- $c {
C { # Locale-dependent era
set d {}
foreach triple [mc LOCALE_ERAS] {
lassign $triple t symbol year
dict set d [string tolower $symbol] $year
}
lassign [UniquePrefixRegexp $d] regex lookup
append re (?: $regex )
}
E {
set l {}
dict set l [string tolower [mc BCE]] BCE
dict set l [string tolower [mc CE]] CE
dict set l b.c.e. BCE
dict set l c.e. CE
dict set l b.c. BCE
dict set l a.d. CE
lassign [UniquePrefixRegexp $l] regex lookup
append re ( $regex )
dict set fieldSet era [incr fieldCount]
append postcode "dict set date era \["\
"dict get " [list $lookup] \
{ } \[ {string tolower $field} \
[incr captureCount] \] \
"\]\n"
}
y { # Locale-dependent year of the era
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
incr captureCount
}
default {
append re %E
if { ! [string is alnum $c] } {
append re \\
}
append re $c
}
}
set state {}
}
%O {
switch -exact -- $c {
d - e {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet dayOfMonth [incr fieldCount]
append postcode "dict set date dayOfMonth \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
H - k {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet hour [incr fieldCount]
append postcode "dict set date hour \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
I - l {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet hourAMPM [incr fieldCount]
append postcode "dict set date hourAMPM \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
m {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet month [incr fieldCount]
append postcode "dict set date month \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
M {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet minute [incr fieldCount]
append postcode "dict set date minute \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
S {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet second [incr fieldCount]
append postcode "dict set date second \[" \
"dict get " [list $lookup] " \$field" \
[incr captureCount] \
"\]\n"
}
u - w {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet dayOfWeek [incr fieldCount]
append postcode "set dow \[dict get " [list $lookup] \
{ $field} [incr captureCount] \] \n \
{
if { $dow == 0 } {
set dow 7
} elseif { $dow > 7 } {
return -code error \
-errorcode [list CLOCK badDayOfWeek] \
"day of week is greater than 7"
}
dict set date dayOfWeek $dow
}
}
y {
lassign [LocaleNumeralMatcher $locale] regex lookup
append re $regex
dict set fieldSet yearOfCentury [incr fieldCount]
append postcode {dict set date yearOfCentury } \[ \
{dict get } [list $lookup] { $field} \
[incr captureCount] \] \n
}
default {
append re %O
if { ! [string is alnum $c] } {
append re \\
}
append re $c
}
}
set state {}
}
}
}
# Clean up any unfinished format groups
append re $state \\s*\$
# Build the procedure
set procBody {}
append procBody "variable TZData" \n
append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
for { set i 1 } { $i <= $captureCount } { incr i } {
append procBody " " field $i
}
append procBody "\] \} \{" \n
append procBody {
return -code error -errorcode [list CLOCK badInputString] \
{input string does not match supplied format}
}
append procBody \}\n
append procBody "set date \[dict create\]" \n
append procBody {dict set date tzName $timeZone} \n
append procBody $postcode
append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
# Set up the time zone before doing anything with a default base date
# that might need a timezone to interpret it.
if { ![dict exists $fieldSet seconds]
&& ![dict exists $fieldSet starDate] } {
if { [dict exists $fieldSet tzName] } {
append procBody {
set timeZone [dict get $date tzName]
}
}
append procBody {
SetupTimeZone $timeZone
}
}
# Add code that gets Julian Day Number from the fields.
append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
# Get time of day
append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
# Assemble seconds from the Julian day and second of the day.
# Convert to local time unless epoch seconds or stardate are
# being processed - they're always absolute
if { ![dict exists $fieldSet seconds]
&& ![dict exists $fieldSet starDate] } {
append procBody {
if { [dict get $date julianDay] > 5373484 } {
return -code error -errorcode [list CLOCK dateTooLarge] \
"requested date too large to represent"
}
dict set date localSeconds [expr {
-210866803200
+ ( 86400 * wide([dict get $date julianDay]) )
+ [dict get $date secondOfDay]
}]
}
# Finally, convert the date to local time
append procBody {
set date [ConvertLocalToUTC $date[set date {}] \
$TZData($timeZone) $changeover]
}
}
# Return result
append procBody {return [dict get $date seconds]} \n
proc $procName { string baseTime timeZone } $procBody
# puts [list proc $procName [list string baseTime timeZone] $procBody]
return $procName
}
#----------------------------------------------------------------------
#
# LocaleNumeralMatcher --
#
# Composes a regexp that captures the numerals in the given locale, and
# a dictionary to map them to conventional numerals.
#
# Parameters:
# locale - Name of the current locale
#
# Results:
# Returns a two-element list comprising the regexp and the dictionary.
#
# Side effects:
# Caches the result.
#
#----------------------------------------------------------------------
proc LocaleNumeralMatcher {l} {
variable LocaleNumeralCache
if { ![dict exists $LocaleNumeralCache $l] } {
set d {}
set i 0
set sep \(
foreach n [mc LOCALE_NUMERALS] {
dict set d $n $i
regsub -all {[^[:alnum:]]} $n \\\\& subex
append re $sep $subex
set sep |
incr i
}
append re \)
dict set LocaleNumeralCache $l [list $re $d]
}
return [dict get $LocaleNumeralCache $l]
}
#----------------------------------------------------------------------
#
# UniquePrefixRegexp --
#
# Composes a regexp that performs unique-prefix matching. The RE
# matches one of a supplied set of strings, or any unique prefix
# thereof.
#
# Parameters:
# data - List of alternating match-strings and values.
# Match-strings with distinct values are considered
# distinct.
#
# Results:
# Returns a two-element list. The first is a regexp that matches any
# unique prefix of any of the strings. The second is a dictionary whose
# keys are match values from the regexp and whose values are the
# corresponding values from 'data'.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc UniquePrefixRegexp { data } {
# The 'successors' dictionary will contain, for each string that is a
# prefix of any key, all characters that may follow that prefix. The
# 'prefixMapping' dictionary will have keys that are prefixes of keys and
# values that correspond to the keys.
set prefixMapping [dict create]
set successors [dict create {} {}]
# Walk the key-value pairs
foreach { key value } $data {
# Construct all prefixes of the key;
set prefix {}
foreach char [split $key {}] {
set oldPrefix $prefix
dict set successors $oldPrefix $char {}
append prefix $char
# Put the prefixes in the 'prefixMapping' and 'successors'
# dictionaries
dict lappend prefixMapping $prefix $value
if { ![dict exists $successors $prefix] } {
dict set successors $prefix {}
}
}
}
# Identify those prefixes that designate unique values, and those that are
# the full keys
set uniquePrefixMapping {}
dict for { key valueList } $prefixMapping {
if { [llength $valueList] == 1 } {
dict set uniquePrefixMapping $key [lindex $valueList 0]
}
}
foreach { key value } $data {
dict set uniquePrefixMapping $key $value
}
# Construct the re.
return [list \
[MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
$uniquePrefixMapping]
}
#----------------------------------------------------------------------
#
# MakeUniquePrefixRegexp --
#
# Service procedure for 'UniquePrefixRegexp' that constructs a regular
# expresison that matches the unique prefixes.
#
# Parameters:
# successors - Dictionary whose keys are all prefixes
# of keys passed to 'UniquePrefixRegexp' and whose
# values are dictionaries whose keys are the characters
# that may follow those prefixes.
# uniquePrefixMapping - Dictionary whose keys are the unique
# prefixes and whose values are not examined.
# prefixString - Current prefix being processed.
#
# Results:
# Returns a constructed regular expression that matches the set of
# unique prefixes beginning with the 'prefixString'.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc MakeUniquePrefixRegexp { successors
uniquePrefixMapping
prefixString } {
# Get the characters that may follow the current prefix string
set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
if { [llength $schars] == 0 } {
return {}
}
# If there is more than one successor character, or if the current prefix
# is a unique prefix, surround the generated re with non-capturing
# parentheses.
set re {}
if {
[dict exists $uniquePrefixMapping $prefixString]
|| [llength $schars] > 1
} then {
append re "(?:"
}
# Generate a regexp that matches the successors.
set sep ""
foreach { c } $schars {
set nextPrefix $prefixString$c
regsub -all {[^[:alnum:]]} $c \\\\& rechar
append re $sep $rechar \
[MakeUniquePrefixRegexp \
$successors $uniquePrefixMapping $nextPrefix]
set sep |
}
# If the current prefix is a unique prefix, make all following text
# optional. Otherwise, if there is more than one successor character,
# close the non-capturing parentheses.
if { [dict exists $uniquePrefixMapping $prefixString] } {
append re ")?"
} elseif { [llength $schars] > 1 } {
append re ")"
}
return $re
}
#----------------------------------------------------------------------
#
# MakeParseCodeFromFields --
#
# Composes Tcl code to extract the Julian Day Number from a dictionary
# containing date fields.
#
# Parameters:
# dateFields -- Dictionary whose keys are fields of the date,
# and whose values are the rightmost positions
# at which those fields appear.
# parseActions -- List of triples: field set, priority, and
# code to emit. Smaller priorities are better, and
# the list must be in ascending order by priority
#
# Results:
# Returns a burst of code that extracts the day number from the given
# date.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc MakeParseCodeFromFields { dateFields parseActions } {
set currPrio 999
set currFieldPos [list]
set currCodeBurst {
error "in MakeParseCodeFromFields: can't happen"
}
foreach { fieldSet prio parseAction } $parseActions {
# If we've found an answer that's better than any that follow, quit
# now.
if { $prio > $currPrio } {
break
}
# Accumulate the field positions that are used in the current field
# grouping.
set fieldPos [list]
set ok true
foreach field $fieldSet {
if { ! [dict exists $dateFields $field] } {
set ok 0
break
}
lappend fieldPos [dict get $dateFields $field]
}
# Quit if we don't have a complete set of fields
if { !$ok } {
continue
}
# Determine whether the current answer is better than the last.
set fPos [lsort -integer -decreasing $fieldPos]
if { $prio == $currPrio } {
foreach currPos $currFieldPos newPos $fPos {
if {
![string is integer $newPos]
|| ![string is integer $currPos]
|| $newPos > $currPos
} then {
break
}
if { $newPos < $currPos } {
set ok 0
break
}
}
}
if { !$ok } {
continue
}
# Remember the best possibility for extracting date information
set currPrio $prio
set currFieldPos $fPos
set currCodeBurst $parseAction
}
return $currCodeBurst
}
#----------------------------------------------------------------------
#
# EnterLocale --
#
# Switch [mclocale] to a given locale if necessary
#
# Parameters:
# locale -- Desired locale
#
# Results:
# Returns the locale that was previously current.
#
# Side effects:
# Does [mclocale]. If necessary, loads the designated locale's files.
#
#----------------------------------------------------------------------
proc EnterLocale { locale } {
if { $locale eq {system} } {
if { $::tcl_platform(platform) ne {windows} } {
# On a non-windows platform, the 'system' locale is the same as
# the 'current' locale
set locale current
} else {
# On a windows platform, the 'system' locale is adapted from the
# 'current' locale by applying the date and time formats from the
# Control Panel. First, load the 'current' locale if it's not yet
# loaded
mcpackagelocale set [mclocale]
# Make a new locale string for the system locale, and get the
# Control Panel information
set locale [mclocale]_windows
if { ! [mcpackagelocale present $locale] } {
LoadWindowsDateTimeFormats $locale
}
}
}
if { $locale eq {current}} {
set locale [mclocale]
}
# Eventually load the locale
mcpackagelocale set $locale
}
#----------------------------------------------------------------------
#
# LoadWindowsDateTimeFormats --
#
# Load the date/time formats from the Control Panel in Windows and
# convert them so that they're usable by Tcl.
#
# Parameters:
# locale - Name of the locale in whose message catalog
# the converted formats are to be stored.
#
# Results:
# None.
#
# Side effects:
# Updates the given message catalog with the locale strings.
#
# Presumes that on entry, [mclocale] is set to the current locale, so that
# default strings can be obtained if the Registry query fails.
#
#----------------------------------------------------------------------
proc LoadWindowsDateTimeFormats { locale } {
# Bail out if we can't find the Registry
variable NoRegistry
if { [info exists NoRegistry] } return
if { ![catch {
registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
sShortDate
} string] } {
set quote {}
set datefmt {}
foreach { unquoted quoted } [split $string '] {
append datefmt $quote [string map {
dddd %A
ddd %a
dd %d
d %e
MMMM %B
MMM %b
MM %m
M %N
yyyy %Y
yy %y
y %y
gg {}
} $unquoted]
if { $quoted eq {} } {
set quote '
} else {
set quote $quoted
}
}
::msgcat::mcset $locale DATE_FORMAT $datefmt
}
if { ![catch {
registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
sLongDate
} string] } {
set quote {}
set ldatefmt {}
foreach { unquoted quoted } [split $string '] {
append ldatefmt $quote [string map {
dddd %A
ddd %a
dd %d
d %e
MMMM %B
MMM %b
MM %m
M %N
yyyy %Y
yy %y
y %y
gg {}
} $unquoted]
if { $quoted eq {} } {
set quote '
} else {
set quote $quoted
}
}
::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
}
if { ![catch {
registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
sTimeFormat
} string] } {
set quote {}
set timefmt {}
foreach { unquoted quoted } [split $string '] {
append timefmt $quote [string map {
HH %H
H %k
hh %I
h %l
mm %M
m %M
ss %S
s %S
tt %p
t %p
} $unquoted]
if { $quoted eq {} } {
set quote '
} else {
set quote $quoted
}
}
::msgcat::mcset $locale TIME_FORMAT $timefmt
}
catch {
::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
}
catch {
::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
}
return
}
#----------------------------------------------------------------------
#
# LocalizeFormat --
#
# Map away locale-dependent format groups in a clock format.
#
# Parameters:
# locale -- Current [mclocale] locale, supplied to avoid
# an extra call
# format -- Format supplied to [clock scan] or [clock format]
#
# Results:
# Returns the string with locale-dependent composite format groups
# substituted out.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc LocalizeFormat { locale format } {
# message catalog key to cache this format
set key FORMAT_$format
if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } {
return [mc $key]
}
# Handle locale-dependent format groups by mapping them out of the format
# string. Note that the order of the [string map] operations is
# significant because later formats can refer to later ones; for example
# %c can refer to %X, which in turn can refer to %T.
set list {
%% %%
%D %m/%d/%Y
%+ {%a %b %e %H:%M:%S %Z %Y}
}
lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]]
lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]]
lappend list %R [string map $list [mc TIME_FORMAT_24]]
lappend list %r [string map $list [mc TIME_FORMAT_12]]
lappend list %X [string map $list [mc TIME_FORMAT]]
lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]]
lappend list %x [string map $list [mc DATE_FORMAT]]
lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]]
lappend list %c [string map $list [mc DATE_TIME_FORMAT]]
lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]]
set format [string map $list $format]
::msgcat::mcset $locale $key $format
return $format
}
#----------------------------------------------------------------------
#
# FormatNumericTimeZone --
#
# Formats a time zone as +hhmmss
#
# Parameters:
# z - Time zone in seconds east of Greenwich
#
# Results:
# Returns the time zone formatted in a numeric form
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc FormatNumericTimeZone { z } {
if { $z < 0 } {
set z [expr { - $z }]
set retval -
} else {
set retval +
}
append retval [::format %02d [expr { $z / 3600 }]]
set z [expr { $z % 3600 }]
append retval [::format %02d [expr { $z / 60 }]]
set z [expr { $z % 60 }]
if { $z != 0 } {
append retval [::format %02d $z]
}
return $retval
}
#----------------------------------------------------------------------
#
# FormatStarDate --
#
# Formats a date as a StarDate.
#
# Parameters:
# date - Dictionary containing 'year', 'dayOfYear', and
# 'localSeconds' fields.
#
# Results:
# Returns the given date formatted as a StarDate.
#
# Side effects:
# None.
#
# Jeff Hobbs put this in to support an atrocious pun about Tcl being
# "Enterprise ready." Now we're stuck with it.
#
#----------------------------------------------------------------------
proc FormatStarDate { date } {
variable Roddenberry
# Get day of year, zero based
set doy [expr { [dict get $date dayOfYear] - 1 }]
# Determine whether the year is a leap year
set lp [IsGregorianLeapYear $date]
# Convert day of year to a fractional year
if { $lp } {
set fractYear [expr { 1000 * $doy / 366 }]
} else {
set fractYear [expr { 1000 * $doy / 365 }]
}
# Put together the StarDate
return [::format "Stardate %02d%03d.%1d" \
[expr { [dict get $date year] - $Roddenberry }] \
$fractYear \
[expr { [dict get $date localSeconds] % 86400
/ ( 86400 / 10 ) }]]
}
#----------------------------------------------------------------------
#
# ParseStarDate --
#
# Parses a StarDate
#
# Parameters:
# year - Year from the Roddenberry epoch
# fractYear - Fraction of a year specifying the day of year.
# fractDay - Fraction of a day
#
# Results:
# Returns a count of seconds from the Posix epoch.
#
# Side effects:
# None.
#
# Jeff Hobbs put this in to support an atrocious pun about Tcl being
# "Enterprise ready." Now we're stuck with it.
#
#----------------------------------------------------------------------
proc ParseStarDate { year fractYear fractDay } {
variable Roddenberry
# Build a tentative date from year and fraction.
set date [dict create \
gregorian 1 \
era CE \
year [expr { $year + $Roddenberry }] \
dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
# Determine whether the given year is a leap year
set lp [IsGregorianLeapYear $date]
# Reconvert the fractional year according to whether the given year is a
# leap year
if { $lp } {
dict set date dayOfYear \
[expr { $fractYear * 366 / 1000 + 1 }]
} else {
dict set date dayOfYear \
[expr { $fractYear * 365 / 1000 + 1 }]
}
dict unset date julianDay
dict unset date gregorian
set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
return [expr {
86400 * [dict get $date julianDay]
- 210866803200
+ ( 86400 / 10 ) * $fractDay
}]
}
#----------------------------------------------------------------------
#
# ScanWide --
#
# Scans a wide integer from an input
#
# Parameters:
# str - String containing a decimal wide integer
#
# Results:
# Returns the string as a pure wide integer. Throws an error if the
# string is misformatted or out of range.
#
#----------------------------------------------------------------------
proc ScanWide { str } {
set count [::scan $str {%ld %c} result junk]
if { $count != 1 } {
return -code error -errorcode [list CLOCK notAnInteger $str] \
"\"$str\" is not an integer"
}
if { [incr result 0] != $str } {
return -code error -errorcode [list CLOCK dateTooLarge] \
"integer value too large to represent"
}
return $result
}
#----------------------------------------------------------------------
#
# InterpretTwoDigitYear --
#
# Given a date that contains only the year of the century, determines
# the target value of a two-digit year.
#
# Parameters:
# date - Dictionary containing fields of the date.
# baseTime - Base time relative to which the date is expressed.
# twoDigitField - Name of the field that stores the two-digit year.
# Default is 'yearOfCentury'
# fourDigitField - Name of the field that will receive the four-digit
# year. Default is 'year'
#
# Results:
# Returns the dictionary augmented with the four-digit year, stored in
# the given key.
#
# Side effects:
# None.
#
# The current rule for interpreting a two-digit year is that the year shall be
# between 1937 and 2037, thus staying within the range of a 32-bit signed
# value for time. This rule may change to a sliding window in future
# versions, so the 'baseTime' parameter (which is currently ignored) is
# provided in the procedure signature.
#
#----------------------------------------------------------------------
proc InterpretTwoDigitYear { date baseTime
{ twoDigitField yearOfCentury }
{ fourDigitField year } } {
set yr [dict get $date $twoDigitField]
if { $yr <= 37 } {
dict set date $fourDigitField [expr { $yr + 2000 }]
} else {
dict set date $fourDigitField [expr { $yr + 1900 }]
}
return $date
}
#----------------------------------------------------------------------
#
# AssignBaseYear --
#
# Places the number of the current year into a dictionary.
#
# Parameters:
# date - Dictionary value to update
# baseTime - Base time from which to extract the year, expressed
# in seconds from the Posix epoch
# timezone - the time zone in which the date is being scanned
# changeover - the Julian Day on which the Gregorian calendar
# was adopted in the target locale.
#
# Results:
# Returns the dictionary with the current year assigned.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AssignBaseYear { date baseTime timezone changeover } {
variable TZData
# Find the Julian Day Number corresponding to the base time, and
# find the Gregorian year corresponding to that Julian Day.
set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
# Store the converted year
dict set date era [dict get $date2 era]
dict set date year [dict get $date2 year]
return $date
}
#----------------------------------------------------------------------
#
# AssignBaseIso8601Year --
#
# Determines the base year in the ISO8601 fiscal calendar.
#
# Parameters:
# date - Dictionary containing the fields of the date that
# is to be augmented with the base year.
# baseTime - Base time expressed in seconds from the Posix epoch.
# timeZone - Target time zone
# changeover - Julian Day of adoption of the Gregorian calendar in
# the target locale.
#
# Results:
# Returns the given date with "iso8601Year" set to the
# base year.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AssignBaseIso8601Year {date baseTime timeZone changeover} {
variable TZData
# Find the Julian Day Number corresponding to the base time
set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
# Calculate the ISO8601 date and transfer the year
dict set date era CE
dict set date iso8601Year [dict get $date2 iso8601Year]
return $date
}
#----------------------------------------------------------------------
#
# AssignBaseMonth --
#
# Places the number of the current year and month into a
# dictionary.
#
# Parameters:
# date - Dictionary value to update
# baseTime - Time from which the year and month are to be
# obtained, expressed in seconds from the Posix epoch.
# timezone - Name of the desired time zone
# changeover - Julian Day on which the Gregorian calendar was adopted.
#
# Results:
# Returns the dictionary with the base year and month assigned.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AssignBaseMonth {date baseTime timezone changeover} {
variable TZData
# Find the year and month corresponding to the base time
set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
dict set date era [dict get $date2 era]
dict set date year [dict get $date2 year]
dict set date month [dict get $date2 month]
return $date
}
#----------------------------------------------------------------------
#
# AssignBaseWeek --
#
# Determines the base year and week in the ISO8601 fiscal calendar.
#
# Parameters:
# date - Dictionary containing the fields of the date that
# is to be augmented with the base year and week.
# baseTime - Base time expressed in seconds from the Posix epoch.
# changeover - Julian Day on which the Gregorian calendar was adopted
# in the target locale.
#
# Results:
# Returns the given date with "iso8601Year" set to the
# base year and "iso8601Week" to the week number.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AssignBaseWeek {date baseTime timeZone changeover} {
variable TZData
# Find the Julian Day Number corresponding to the base time
set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
# Calculate the ISO8601 date and transfer the year
dict set date era CE
dict set date iso8601Year [dict get $date2 iso8601Year]
dict set date iso8601Week [dict get $date2 iso8601Week]
return $date
}
#----------------------------------------------------------------------
#
# AssignBaseJulianDay --
#
# Determines the base day for a time-of-day conversion.
#
# Parameters:
# date - Dictionary that is to get the base day
# baseTime - Base time expressed in seconds from the Posix epoch
# changeover - Julian day on which the Gregorian calendar was
# adpoted in the target locale.
#
# Results:
# Returns the given dictionary augmented with a 'julianDay' field
# that contains the base day.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AssignBaseJulianDay { date baseTime timeZone changeover } {
variable TZData
# Find the Julian Day Number corresponding to the base time
set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
dict set date julianDay [dict get $date2 julianDay]
return $date
}
#----------------------------------------------------------------------
#
# InterpretHMSP --
#
# Interprets a time in the form "hh:mm:ss am".
#
# Parameters:
# date -- Dictionary containing "hourAMPM", "minute", "second"
# and "amPmIndicator" fields.
#
# Results:
# Returns the number of seconds from local midnight.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc InterpretHMSP { date } {
set hr [dict get $date hourAMPM]
if { $hr == 12 } {
set hr 0
}
if { [dict get $date amPmIndicator] } {
incr hr 12
}
dict set date hour $hr
return [InterpretHMS $date[set date {}]]
}
#----------------------------------------------------------------------
#
# InterpretHMS --
#
# Interprets a 24-hour time "hh:mm:ss"
#
# Parameters:
# date -- Dictionary containing the "hour", "minute" and "second"
# fields.
#
# Results:
# Returns the given dictionary augmented with a "secondOfDay"
# field containing the number of seconds from local midnight.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc InterpretHMS { date } {
return [expr {
( [dict get $date hour] * 60
+ [dict get $date minute] ) * 60
+ [dict get $date second]
}]
}
#----------------------------------------------------------------------
#
# GetSystemTimeZone --
#
# Determines the system time zone, which is the default for the
# 'clock' command if no other zone is supplied.
#
# Parameters:
# None.
#
# Results:
# Returns the system time zone.
#
# Side effects:
# Stores the system time zone in the 'CachedSystemTimeZone'
# variable, since determining it may be an expensive process.
#
#----------------------------------------------------------------------
proc GetSystemTimeZone {} {
variable CachedSystemTimeZone
variable TimeZoneBad
if {[set result [getenv TCL_TZ]] ne {}} {
set timezone $result
} elseif {[set result [getenv TZ]] ne {}} {
set timezone $result
} else {
# Cache the time zone only if it was detected by one of the
# expensive methods.
if { [info exists CachedSystemTimeZone] } {
set timezone $CachedSystemTimeZone
} elseif { $::tcl_platform(platform) eq {windows} } {
set timezone [GuessWindowsTimeZone]
} elseif { [file exists /etc/localtime]
&& ![catch {ReadZoneinfoFile \
Tcl/Localtime /etc/localtime}] } {
set timezone :Tcl/Localtime
} else {
set timezone :localtime
}
set CachedSystemTimeZone $timezone
}
if { ![dict exists $TimeZoneBad $timezone] } {
dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
}
if { [dict get $TimeZoneBad $timezone] } {
return :localtime
} else {
return $timezone
}
}
#----------------------------------------------------------------------
#
# ConvertLegacyTimeZone --
#
# Given an alphanumeric time zone identifier and the system time zone,
# convert the alphanumeric identifier to an unambiguous time zone.
#
# Parameters:
# tzname - Name of the time zone to convert
#
# Results:
# Returns a time zone name corresponding to tzname, but in an
# unambiguous form, generally +hhmm.
#
# This procedure is implemented primarily to allow the parsing of RFC822
# date/time strings. Processing a time zone name on input is not recommended
# practice, because there is considerable room for ambiguity; for instance, is
# BST Brazilian Standard Time, or British Summer Time?
#
#----------------------------------------------------------------------
proc ConvertLegacyTimeZone { tzname } {
variable LegacyTimeZone
set tzname [string tolower $tzname]
if { ![dict exists $LegacyTimeZone $tzname] } {
return -code error -errorcode [list CLOCK badTZName $tzname] \
"time zone \"$tzname\" not found"
}
return [dict get $LegacyTimeZone $tzname]
}
#----------------------------------------------------------------------
#
# SetupTimeZone --
#
# Given the name or specification of a time zone, sets up its in-memory
# data.
#
# Parameters:
# tzname - Name of a time zone
#
# Results:
# Unless the time zone is ':localtime', sets the TZData array to contain
# the lookup table for local<->UTC conversion. Returns an error if the
# time zone cannot be parsed.
#
#----------------------------------------------------------------------
proc SetupTimeZone { timezone } {
variable TZData
if {! [info exists TZData($timezone)] } {
variable MINWIDE
if { $timezone eq {:localtime} } {
# Nothing to do, we'll convert using the localtime function
} elseif {
[regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
-> s hh mm ss]
} then {
# Make a fixed offset
::scan $hh %d hh
if { $mm eq {} } {
set mm 0
} else {
::scan $mm %d mm
}
if { $ss eq {} } {
set ss 0
} else {
::scan $ss %d ss
}
set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
if { $s eq {-} } {
set offset [expr { - $offset }]
}
set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
} elseif { [string index $timezone 0] eq {:} } {
# Convert using a time zone file
if {
[catch {
LoadTimeZoneFile [string range $timezone 1 end]
}] && [catch {
LoadZoneinfoFile [string range $timezone 1 end]
}]
} then {
return -code error \
-errorcode [list CLOCK badTimeZone $timezone] \
"time zone \"$timezone\" not found"
}
} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
# This looks like a POSIX time zone - try to process it
if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
dict unset opts -errorinfo
}
return -options $opts $data
} else {
set TZData($timezone) $data
}
} else {
# We couldn't parse this as a POSIX time zone. Try again with a
# time zone file - this time without a colon
if { [catch { LoadTimeZoneFile $timezone }]
&& [catch { LoadZoneinfoFile $timezone } - opts] } {
dict unset opts -errorinfo
return -options $opts "time zone $timezone not found"
}
set TZData($timezone) $TZData(:$timezone)
}
}
return
}
#----------------------------------------------------------------------
#
# GuessWindowsTimeZone --
#
# Determines the system time zone on windows.
#
# Parameters:
# None.
#
# Results:
# Returns a time zone specifier that corresponds to the system time zone
# information found in the Registry.
#
# Bugs:
# Fixed dates for DST change are unimplemented at present, because no
# time zone information supplied with Windows actually uses them!
#
# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified,
# GuessWindowsTimeZone looks in the Registry for the system time zone
# information. It then attempts to find an entry in WinZoneInfo for a time
# zone that uses the same rules. If it finds one, it returns it; otherwise,
# it constructs a Posix-style time zone string and returns that.
#
#----------------------------------------------------------------------
proc GuessWindowsTimeZone {} {
variable WinZoneInfo
variable NoRegistry
variable TimeZoneBad
if { [info exists NoRegistry] } {
return :localtime
}
# Dredge time zone information out of the registry
if { [catch {
set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
set data [list \
[expr { -60
* [registry get $rpath Bias] }] \
[expr { -60
* [registry get $rpath StandardBias] }] \
[expr { -60 \
* [registry get $rpath DaylightBias] }]]
set stdtzi [registry get $rpath StandardStart]
foreach ind {0 2 14 4 6 8 10 12} {
binary scan $stdtzi @${ind}s val
lappend data $val
}
set daytzi [registry get $rpath DaylightStart]
foreach ind {0 2 14 4 6 8 10 12} {
binary scan $daytzi @${ind}s val
lappend data $val
}
}] } {
# Missing values in the Registry - bail out
return :localtime
}
# Make up a Posix time zone specifier if we can't find one. Check here
# that the tzdata file exists, in case we're running in an environment
# (e.g. starpack) where tzdata is incomplete. (Bug 1237907)
if { [dict exists $WinZoneInfo $data] } {
set tzname [dict get $WinZoneInfo $data]
if { ! [dict exists $TimeZoneBad $tzname] } {
dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
}
} else {
set tzname {}
}
if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } {
lassign $data \
bias stdBias dstBias \
stdYear stdMonth stdDayOfWeek stdDayOfMonth \
stdHour stdMinute stdSecond stdMillisec \
dstYear dstMonth dstDayOfWeek dstDayOfMonth \
dstHour dstMinute dstSecond dstMillisec
set stdDelta [expr { $bias + $stdBias }]
set dstDelta [expr { $bias + $dstBias }]
if { $stdDelta <= 0 } {
set stdSignum +
set stdDelta [expr { - $stdDelta }]
set dispStdSignum -
} else {
set stdSignum -
set dispStdSignum +
}
set hh [::format %02d [expr { $stdDelta / 3600 }]]
set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
set ss [::format %02d [expr { $stdDelta % 60 }]]
set tzname {}
append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
if { $stdMonth >= 0 } {
if { $dstDelta <= 0 } {
set dstSignum +
set dstDelta [expr { - $dstDelta }]
set dispDstSignum -
} else {
set dstSignum -
set dispDstSignum +
}
set hh [::format %02d [expr { $dstDelta / 3600 }]]
set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
set ss [::format %02d [expr { $dstDelta % 60 }]]
append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
if { $dstYear == 0 } {
append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
} else {
# I have not been able to find any locale on which Windows
# converts time zone on a fixed day of the year, hence don't
# know how to interpret the fields. If someone can inform me,
# I'd be glad to code it up. For right now, we bail out in
# such a case.
return :localtime
}
append tzname / [::format %02d $dstHour] \
: [::format %02d $dstMinute] \
: [::format %02d $dstSecond]
if { $stdYear == 0 } {
append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
} else {
# I have not been able to find any locale on which Windows
# converts time zone on a fixed day of the year, hence don't
# know how to interpret the fields. If someone can inform me,
# I'd be glad to code it up. For right now, we bail out in
# such a case.
return :localtime
}
append tzname / [::format %02d $stdHour] \
: [::format %02d $stdMinute] \
: [::format %02d $stdSecond]
}
dict set WinZoneInfo $data $tzname
}
return [dict get $WinZoneInfo $data]
}
#----------------------------------------------------------------------
#
# LoadTimeZoneFile --
#
# Load the data file that specifies the conversion between a
# given time zone and Greenwich.
#
# Parameters:
# fileName -- Name of the file to load
#
# Results:
# None.
#
# Side effects:
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc LoadTimeZoneFile { fileName } {
variable DataDir
variable TZData
if { [info exists TZData($fileName)] } {
return
}
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
}
try {
source [file join $DataDir $fileName]
} on error {} {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
"time zone \":$fileName\" not found"
}
return
}
#----------------------------------------------------------------------
#
# LoadZoneinfoFile --
#
# Loads a binary time zone information file in Olson format.
#
# Parameters:
# fileName - Relative path name of the file to load.
#
# Results:
# Returns an empty result normally; returns an error if no Olson file
# was found or the file was malformed in some way.
#
# Side effects:
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc LoadZoneinfoFile { fileName } {
variable ZoneinfoPaths
# Since an unsafe interp uses the [clock] command in the parent, this code
# is security sensitive. Make sure that the path name cannot escape the
# given directory.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
}
foreach d $ZoneinfoPaths {
set fname [file join $d $fileName]
if { [file readable $fname] && [file isfile $fname] } {
break
}
unset fname
}
ReadZoneinfoFile $fileName $fname
}
#----------------------------------------------------------------------
#
# ReadZoneinfoFile --
#
# Loads a binary time zone information file in Olson format.
#
# Parameters:
# fileName - Name of the time zone (relative path name of the
# file).
# fname - Absolute path name of the file.
#
# Results:
# Returns an empty result normally; returns an error if no Olson file
# was found or the file was malformed in some way.
#
# Side effects:
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
proc ReadZoneinfoFile {fileName fname} {
variable MINWIDE
variable TZData
if { ![file exists $fname] } {
return -code error "$fileName not found"
}
if { [file size $fname] > 262144 } {
return -code error "$fileName too big"
}
# Suck in all the data from the file
set f [open $fname r]
fconfigure $f -translation binary
set d [read $f]
close $f
# The file begins with a magic number, sixteen reserved bytes, and then
# six 4-byte integers giving counts of fields in the file.
binary scan $d a4a1x15IIIIII \
magic version nIsGMT nIsStd nLeap nTime nType nChar
set seek 44
set ilen 4
set iformat I
if { $magic != {TZif} } {
return -code error "$fileName not a time zone information file"
}
if { $nType > 255 } {
return -code error "$fileName contains too many time types"
}
# Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots.
if { $nLeap != 0 } {
return -code error "$fileName contains leap seconds"
}
# In a version 2 file, we use the second part of the file, which contains
# 64-bit transition times.
if {$version eq "2"} {
set seek [expr {
44
+ 5 * $nTime
+ 6 * $nType
+ 4 * $nLeap
+ $nIsStd
+ $nIsGMT
+ $nChar
}]
binary scan $d @${seek}a4a1x15IIIIII \
magic version nIsGMT nIsStd nLeap nTime nType nChar
if {$magic ne {TZif}} {
return -code error "seek address $seek miscomputed, magic = $magic"
}
set iformat W
set ilen 8
incr seek 44
}
# Next come ${nTime} transition times, followed by ${nTime} time type
# codes. The type codes are unsigned 1-byte quantities. We insert an
# arbitrary start time in front of the transitions.
binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
incr seek [expr { ($ilen + 1) * $nTime }]
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
lappend codes [expr { $c & 0xFF }]
}
set codes [linsert $codes 0 0]
# Next come ${nType} time type descriptions, each of which has an offset
# (seconds east of GMT), a DST indicator, and an index into the
# abbreviation text.
for { set i 0 } { $i < $nType } { incr i } {
binary scan $d @${seek}Icc gmtOff isDst abbrInd
lappend types [list $gmtOff $isDst $abbrInd]
incr seek 6
}
# Next come $nChar characters of time zone name abbreviations, which are
# null-terminated.
# We build them up into a dictionary indexed by character index, because
# that's what's in the indices above.
binary scan $d @${seek}a${nChar} abbrs
incr seek ${nChar}
set abbrList [split $abbrs \0]
set i 0
set abbrevs {}
foreach a $abbrList {
for {set j 0} {$j <= [string length $a]} {incr j} {
dict set abbrevs $i [string range $a $j end]
incr i
}
}
# Package up a list of tuples, each of which contains transition time,
# seconds east of Greenwich, DST flag and time zone abbreviation.
set r {}
set lastTime $MINWIDE
foreach t $times c $codes {
if { $t < $lastTime } {
return -code error "$fileName has times out of order"
}
set lastTime $t
lassign [lindex $types $c] gmtoff isDst abbrInd
set abbrev [dict get $abbrevs $abbrInd]
lappend r [list $t $gmtoff $isDst $abbrev]
}
# In a version 2 file, there is also a POSIX-style time zone description
# at the very end of the file. To get to it, skip over nLeap leap second
# values (8 bytes each),
# nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
if {$version eq {2}} {
set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
set last [string first \n $d $seek]
set posix [string range $d $seek [expr {$last-1}]]
if {[llength $posix] > 0} {
set posixFields [ParsePosixTimeZone $posix]
foreach tuple [ProcessPosixTimeZone $posixFields] {
lassign $tuple t gmtoff isDst abbrev
if {$t > $lastTime} {
lappend r $tuple
}
}
}
}
set TZData(:$fileName) $r
return
}
#----------------------------------------------------------------------
#
# ParsePosixTimeZone --
#
# Parses the TZ environment variable in Posix form
#
# Parameters:
# tz Time zone specifier to be interpreted
#
# Results:
# Returns a dictionary whose values contain the various pieces of the
# time zone specification.
#
# Side effects:
# None.
#
# Errors:
# Throws an error if the syntax of the time zone is incorrect.
#
# The following keys are present in the dictionary:
# stdName - Name of the time zone when Daylight Saving Time
# is not in effect.
# stdSignum - Sign (+, -, or empty) of the offset from Greenwich
# to the given (non-DST) time zone. + and the empty
# string denote zones west of Greenwich, - denotes east
# of Greenwich; this is contrary to the ISO convention
# but follows Posix.
# stdHours - Hours part of the offset from Greenwich to the given
# (non-DST) time zone.
# stdMinutes - Minutes part of the offset from Greenwich to the
# given (non-DST) time zone. Empty denotes zero.
# stdSeconds - Seconds part of the offset from Greenwich to the
# given (non-DST) time zone. Empty denotes zero.
# dstName - Name of the time zone when DST is in effect, or the
# empty string if the time zone does not observe Daylight
# Saving Time.
# dstSignum, dstHours, dstMinutes, dstSeconds -
# Fields corresponding to stdSignum, stdHours, stdMinutes,
# stdSeconds for the Daylight Saving Time version of the
# time zone. If dstHours is empty, it is presumed to be 1.
# startDayOfYear - The ordinal number of the day of the year on which
# Daylight Saving Time begins. If this field is
# empty, then DST begins on a given month-week-day,
# as below.
# startJ - The letter J, or an empty string. If a J is present in
# this field, then startDayOfYear does not count February 29
# even in leap years.
# startMonth - The number of the month in which Daylight Saving Time
# begins, supplied if startDayOfYear is empty. If both
# startDayOfYear and startMonth are empty, then US rules
# are presumed.
# startWeekOfMonth - The number of the week in the month in which
# Daylight Saving Time begins, in the range 1-5.
# 5 denotes the last week of the month even in a
# 4-week month.
# startDayOfWeek - The number of the day of the week (Sunday=0,
# Saturday=6) on which Daylight Saving Time begins.
# startHours - The hours part of the time of day at which Daylight
# Saving Time begins. An empty string is presumed to be 2.
# startMinutes - The minutes part of the time of day at which DST begins.
# An empty string is presumed zero.
# startSeconds - The seconds part of the time of day at which DST begins.
# An empty string is presumed zero.
# endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
# endHours, endMinutes, endSeconds -
# Specify the end of DST in the same way that the start* fields
# specify the beginning of DST.
#
# This procedure serves only to break the time specifier into fields. No
# attempt is made to canonicalize the fields or supply default values.
#
#----------------------------------------------------------------------
proc ParsePosixTimeZone { tz } {
if {[regexp -expanded -nocase -- {
^
# 1 - Standard time zone name
([[:alpha:]]+ | <[-+[:alnum:]]+>)
# 2 - Standard time zone offset, signum
([-+]?)
# 3 - Standard time zone offset, hours
([[:digit:]]{1,2})
(?:
# 4 - Standard time zone offset, minutes
: ([[:digit:]]{1,2})
(?:
# 5 - Standard time zone offset, seconds
: ([[:digit:]]{1,2} )
)?
)?
(?:
# 6 - DST time zone name
([[:alpha:]]+ | <[-+[:alnum:]]+>)
(?:
(?:
# 7 - DST time zone offset, signum
([-+]?)
# 8 - DST time zone offset, hours
([[:digit:]]{1,2})
(?:
# 9 - DST time zone offset, minutes
: ([[:digit:]]{1,2})
(?:
# 10 - DST time zone offset, seconds
: ([[:digit:]]{1,2})
)?
)?
)?
(?:
,
(?:
# 11 - Optional J in n and Jn form 12 - Day of year
( J ? ) ( [[:digit:]]+ )
| M
# 13 - Month number 14 - Week of month 15 - Day of week
( [[:digit:]] + )
[.] ( [[:digit:]] + )
[.] ( [[:digit:]] + )
)
(?:
# 16 - Start time of DST - hours
/ ( [[:digit:]]{1,2} )
(?:
# 17 - Start time of DST - minutes
: ( [[:digit:]]{1,2} )
(?:
# 18 - Start time of DST - seconds
: ( [[:digit:]]{1,2} )
)?
)?
)?
,
(?:
# 19 - Optional J in n and Jn form 20 - Day of year
( J ? ) ( [[:digit:]]+ )
| M
# 21 - Month number 22 - Week of month 23 - Day of week
( [[:digit:]] + )
[.] ( [[:digit:]] + )
[.] ( [[:digit:]] + )
)
(?:
# 24 - End time of DST - hours
/ ( [[:digit:]]{1,2} )
(?:
# 25 - End time of DST - minutes
: ( [[:digit:]]{1,2} )
(?:
# 26 - End time of DST - seconds
: ( [[:digit:]]{1,2} )
)?
)?
)?
)?
)?
)?
$
} $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
x(startJ) x(startDayOfYear) \
x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
x(startHours) x(startMinutes) x(startSeconds) \
x(endJ) x(endDayOfYear) \
x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
x(endHours) x(endMinutes) x(endSeconds)] } {
# it's a good timezone
return [array get x]
}
return -code error\
-errorcode [list CLOCK badTimeZone $tz] \
"unable to parse time zone specification \"$tz\""
}
#----------------------------------------------------------------------
#
# ProcessPosixTimeZone --
#
# Handle a Posix time zone after it's been broken out into fields.
#
# Parameters:
# z - Dictionary returned from 'ParsePosixTimeZone'
#
# Results:
# Returns time zone information for the 'TZData' array.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc ProcessPosixTimeZone { z } {
variable MINWIDE
variable TZData
# Determine the standard time zone name and seconds east of Greenwich
set stdName [dict get $z stdName]
if { [string index $stdName 0] eq {<} } {
set stdName [string range $stdName 1 end-1]
}
if { [dict get $z stdSignum] eq {-} } {
set stdSignum +1
} else {
set stdSignum -1
}
set stdHours [lindex [::scan [dict get $z stdHours] %d] 0]
if { [dict get $z stdMinutes] ne {} } {
set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0]
} else {
set stdMinutes 0
}
if { [dict get $z stdSeconds] ne {} } {
set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0]
} else {
set stdSeconds 0
}
set stdOffset [expr {
(($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum
}]
set data [list [list $MINWIDE $stdOffset 0 $stdName]]
# If there's no daylight zone, we're done
set dstName [dict get $z dstName]
if { $dstName eq {} } {
return $data
}
if { [string index $dstName 0] eq {<} } {
set dstName [string range $dstName 1 end-1]
}
# Determine the daylight name
if { [dict get $z dstSignum] eq {-} } {
set dstSignum +1
} else {
set dstSignum -1
}
if { [dict get $z dstHours] eq {} } {
set dstOffset [expr { 3600 + $stdOffset }]
} else {
set dstHours [lindex [::scan [dict get $z dstHours] %d] 0]
if { [dict get $z dstMinutes] ne {} } {
set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0]
} else {
set dstMinutes 0
}
if { [dict get $z dstSeconds] ne {} } {
set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0]
} else {
set dstSeconds 0
}
set dstOffset [expr {
(($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum
}]
}
# Fill in defaults for European or US DST rules
# US start time is the second Sunday in March
# EU start time is the last Sunday in March
# US end time is the first Sunday in November.
# EU end time is the last Sunday in October
if {
[dict get $z startDayOfYear] eq {}
&& [dict get $z startMonth] eq {}
} then {
if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
# EU
dict set z startWeekOfMonth 5
if {$stdHours>2} {
dict set z startHours 2
} else {
dict set z startHours [expr {$stdHours+1}]
}
} else {
# US
dict set z startWeekOfMonth 2
dict set z startHours 2
}
dict set z startMonth 3
dict set z startDayOfWeek 0
dict set z startMinutes 0
dict set z startSeconds 0
}
if {
[dict get $z endDayOfYear] eq {}
&& [dict get $z endMonth] eq {}
} then {
if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
# EU
dict set z endMonth 10
dict set z endWeekOfMonth 5
if {$stdHours>2} {
dict set z endHours 3
} else {
dict set z endHours [expr {$stdHours+2}]
}
} else {
# US
dict set z endMonth 11
dict set z endWeekOfMonth 1
dict set z endHours 2
}
dict set z endDayOfWeek 0
dict set z endMinutes 0
dict set z endSeconds 0
}
# Put DST in effect in all years from 1916 to 2099.
for { set y 1916 } { $y < 2100 } { incr y } {
set startTime [DeterminePosixDSTTime $z start $y]
incr startTime [expr { - wide($stdOffset) }]
set endTime [DeterminePosixDSTTime $z end $y]
incr endTime [expr { - wide($dstOffset) }]
if { $startTime < $endTime } {
lappend data \
[list $startTime $dstOffset 1 $dstName] \
[list $endTime $stdOffset 0 $stdName]
} else {
lappend data \
[list $endTime $stdOffset 0 $stdName] \
[list $startTime $dstOffset 1 $dstName]
}
}
return $data
}
#----------------------------------------------------------------------
#
# DeterminePosixDSTTime --
#
# Determines the time that Daylight Saving Time starts or ends from a
# Posix time zone specification.
#
# Parameters:
# z - Time zone data returned from ParsePosixTimeZone.
# Missing fields are expected to be filled in with
# default values.
# bound - The word 'start' or 'end'
# y - The year for which the transition time is to be determined.
#
# Results:
# Returns the transition time as a count of seconds from the epoch. The
# time is relative to the wall clock, not UTC.
#
#----------------------------------------------------------------------
proc DeterminePosixDSTTime { z bound y } {
variable FEB_28
# Determine the start or end day of DST
set date [dict create era CE year $y]
set doy [dict get $z ${bound}DayOfYear]
if { $doy ne {} } {
# Time was specified as a day of the year
if { [dict get $z ${bound}J] ne {}
&& [IsGregorianLeapYear $y]
&& ( $doy > $FEB_28 ) } {
incr doy
}
dict set date dayOfYear $doy
set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
} else {
# Time was specified as a day of the week within a month
dict set date month [dict get $z ${bound}Month]
dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
set dowim [dict get $z ${bound}WeekOfMonth]
if { $dowim >= 5 } {
set dowim -1
}
dict set date dayOfWeekInMonth $dowim
set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
}
set jd [dict get $date julianDay]
set seconds [expr {
wide($jd) * wide(86400) - wide(210866803200)
}]
set h [dict get $z ${bound}Hours]
if { $h eq {} } {
set h 2
} else {
set h [lindex [::scan $h %d] 0]
}
set m [dict get $z ${bound}Minutes]
if { $m eq {} } {
set m 0
} else {
set m [lindex [::scan $m %d] 0]
}
set s [dict get $z ${bound}Seconds]
if { $s eq {} } {
set s 0
} else {
set s [lindex [::scan $s %d] 0]
}
set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
return [expr { $seconds + $tod }]
}
#----------------------------------------------------------------------
#
# GetLocaleEra --
#
# Given local time expressed in seconds from the Posix epoch,
# determine localized era and year within the era.
#
# Parameters:
# date - Dictionary that must contain the keys, 'localSeconds',
# whose value is expressed as the appropriate local time;
# and 'year', whose value is the Gregorian year.
# etable - Value of the LOCALE_ERAS key in the message catalogue
# for the target locale.
#
# Results:
# Returns the dictionary, augmented with the keys, 'localeEra' and
# 'localeYear'.
#
#----------------------------------------------------------------------
proc GetLocaleEra { date etable } {
set index [BSearch $etable [dict get $date localSeconds]]
if { $index < 0} {
dict set date localeEra \
[::format %02d [expr { [dict get $date year] / 100 }]]
dict set date localeYear [expr {
[dict get $date year] % 100
}]
} else {
dict set date localeEra [lindex $etable $index 1]
dict set date localeYear [expr {
[dict get $date year] - [lindex $etable $index 2]
}]
}
return $date
}
#----------------------------------------------------------------------
#
# GetJulianDayFromEraYearDay --
#
# Given a year, month and day on the Gregorian calendar, determines
# the Julian Day Number beginning at noon on that date.
#
# Parameters:
# date -- A dictionary in which the 'era', 'year', and
# 'dayOfYear' slots are populated. The calendar in use
# is determined by the date itself relative to:
# changeover -- Julian day on which the Gregorian calendar was
# adopted in the current locale.
#
# Results:
# Returns the given dictionary augmented with a 'julianDay' key whose
# value is the desired Julian Day Number, and a 'gregorian' key that
# specifies whether the calendar is Gregorian (1) or Julian (0).
#
# Side effects:
# None.
#
# Bugs:
# This code needs to be moved to the C layer.
#
#----------------------------------------------------------------------
proc GetJulianDayFromEraYearDay {date changeover} {
# Get absolute year number from the civil year
switch -exact -- [dict get $date era] {
BCE {
set year [expr { 1 - [dict get $date year] }]
}
CE {
set year [dict get $date year]
}
}
set ym1 [expr { $year - 1 }]
# Try the Gregorian calendar first.
dict set date gregorian 1
set jd [expr {
1721425
+ [dict get $date dayOfYear]
+ ( 365 * $ym1 )
+ ( $ym1 / 4 )
- ( $ym1 / 100 )
+ ( $ym1 / 400 )
}]
# If the date is before the Gregorian change, use the Julian calendar.
if { $jd < $changeover } {
dict set date gregorian 0
set jd [expr {
1721423
+ [dict get $date dayOfYear]
+ ( 365 * $ym1 )
+ ( $ym1 / 4 )
}]
}
dict set date julianDay $jd
return $date
}
#----------------------------------------------------------------------
#
# GetJulianDayFromEraYearMonthWeekDay --
#
# Determines the Julian Day number corresponding to the nth given
# day-of-the-week in a given month.
#
# Parameters:
# date - Dictionary containing the keys, 'era', 'year', 'month'
# 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
# changeover - Julian Day of adoption of the Gregorian calendar
#
# Results:
# Returns the given dictionary, augmented with a 'julianDay' key.
#
# Side effects:
# None.
#
# Bugs:
# This code needs to be moved to the C layer.
#
#----------------------------------------------------------------------
proc GetJulianDayFromEraYearMonthWeekDay {date changeover} {
# Come up with a reference day; either the zeroeth day of the given month
# (dayOfWeekInMonth >= 0) or the seventh day of the following month
# (dayOfWeekInMonth < 0)
set date2 $date
set week [dict get $date dayOfWeekInMonth]
if { $week >= 0 } {
dict set date2 dayOfMonth 0
} else {
dict incr date2 month
dict set date2 dayOfMonth 7
}
set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
$changeover]
set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
[dict get $date2 julianDay]]
dict set date julianDay [expr { $wd0 + 7 * $week }]
return $date
}
#----------------------------------------------------------------------
#
# IsGregorianLeapYear --
#
# Determines whether a given date represents a leap year in the
# Gregorian calendar.
#
# Parameters:
# date -- The date to test. The fields, 'era', 'year' and 'gregorian'
# must be set.
#
# Results:
# Returns 1 if the year is a leap year, 0 otherwise.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc IsGregorianLeapYear { date } {
switch -exact -- [dict get $date era] {
BCE {
set year [expr { 1 - [dict get $date year]}]
}
CE {
set year [dict get $date year]
}
}
if { $year % 4 != 0 } {
return 0
} elseif { ![dict get $date gregorian] } {
return 1
} elseif { $year % 400 == 0 } {
return 1
} elseif { $year % 100 == 0 } {
return 0
} else {
return 1
}
}
#----------------------------------------------------------------------
#
# WeekdayOnOrBefore --
#
# Determine the nearest day of week (given by the 'weekday' parameter,
# Sunday==0) on or before a given Julian Day.
#
# Parameters:
# weekday -- Day of the week
# j -- Julian Day number
#
# Results:
# Returns the Julian Day Number of the desired date.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc WeekdayOnOrBefore { weekday j } {
set k [expr { ( $weekday + 6 ) % 7 }]
return [expr { $j - ( $j - $k ) % 7 }]
}
#----------------------------------------------------------------------
#
# BSearch --
#
# Service procedure that does binary search in several places inside the
# 'clock' command.
#
# Parameters:
# list - List of lists, sorted in ascending order by the
# first elements
# key - Value to search for
#
# Results:
# Returns the index of the greatest element in $list that is less than
# or equal to $key.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc BSearch { list key } {
if {[llength $list] == 0} {
return -1
}
if { $key < [lindex $list 0 0] } {
return -1
}
set l 0
set u [expr { [llength $list] - 1 }]
while { $l < $u } {
# At this point, we know that
# $k >= [lindex $list $l 0]
# Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
# We find the midpoint of the interval {l,u} rounded UP, compare
# against it, and set l or u to maintain the invariant. Note that the
# interval shrinks at each step, guaranteeing convergence.
set m [expr { ( $l + $u + 1 ) / 2 }]
if { $key >= [lindex $list $m 0] } {
set l $m
} else {
set u [expr { $m - 1 }]
}
}
return $l
}
#----------------------------------------------------------------------
#
# clock add --
#
# Adds an offset to a given time.
#
# Syntax:
# clock add clockval ?count unit?... ?-option value?
#
# Parameters:
# clockval -- Starting time value
# count -- Amount of a unit of time to add
# unit -- Unit of time to add, must be one of:
# years year months month weeks week
# days day hours hour minutes minute
# seconds second
#
# Options:
# -gmt BOOLEAN
# (Deprecated) Flag synonymous with '-timezone :GMT'
# -timezone ZONE
# Name of the time zone in which calculations are to be done.
# -locale NAME
# Name of the locale in which calculations are to be done.
# Used to determine the Gregorian change date.
#
# Results:
# Returns the given time adjusted by the given offset(s) in
# order.
#
# Notes:
# It is possible that adding a number of months or years will adjust the
# day of the month as well. For instance, the time at one month after
# 31 January is either 28 or 29 February, because February has fewer
# than 31 days.
#
#----------------------------------------------------------------------
proc add { clockval args } {
if { [llength $args] % 2 != 0 } {
set cmdName "clock add"
return -code error \
-errorcode [list CLOCK wrongNumArgs] \
"wrong \# args: should be\
\"$cmdName clockval ?number units?...\
?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
}
if { [catch { expr {wide($clockval)} } result] } {
return -code error $result
}
set offsets {}
set gmt 0
set locale c
set timezone [GetSystemTimeZone]
foreach { a b } $args {
if { [string is integer -strict $a] } {
lappend offsets $a $b
} else {
switch -exact -- $a {
-g - -gm - -gmt {
set saw(-gmt) {}
set gmt $b
}
-l - -lo - -loc - -loca - -local - -locale {
set locale [string tolower $b]
}
-t - -ti - -tim - -time - -timez - -timezo - -timezon -
-timezone {
set saw(-timezone) {}
set timezone $b
}
default {
throw [list CLOCK badOption $a] \
"bad option \"$a\":\
must be -gmt, -locale or -timezone"
}
}
}
}
# Check options for validity
if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
return -code error \
-errorcode [list CLOCK gmtWithTimezone] \
"cannot use -gmt and -timezone in same call"
}
if { [catch { expr { wide($clockval) } } result] } {
return -code error "expected integer but got \"$clockval\""
}
if { ![string is boolean -strict $gmt] } {
return -code error "expected boolean value but got \"$gmt\""
} elseif { $gmt } {
set timezone :GMT
}
EnterLocale $locale
set changeover [mc GREGORIAN_CHANGE_DATE]
if {[catch {SetupTimeZone $timezone} retval opts]} {
dict unset opts -errorinfo
return -options $opts $retval
}
try {
foreach { quantity unit } $offsets {
switch -exact -- $unit {
years - year {
set clockval [AddMonths [expr { 12 * $quantity }] \
$clockval $timezone $changeover]
}
months - month {
set clockval [AddMonths $quantity $clockval $timezone \
$changeover]
}
weeks - week {
set clockval [AddDays [expr { 7 * $quantity }] \
$clockval $timezone $changeover]
}
days - day {
set clockval [AddDays $quantity $clockval $timezone \
$changeover]
}
hours - hour {
set clockval [expr { 3600 * $quantity + $clockval }]
}
minutes - minute {
set clockval [expr { 60 * $quantity + $clockval }]
}
seconds - second {
set clockval [expr { $quantity + $clockval }]
}
default {
throw [list CLOCK badUnit $unit] \
"unknown unit \"$unit\", must be \
years, months, weeks, days, hours, minutes or seconds"
}
}
}
return $clockval
} trap CLOCK {result opts} {
# Conceal the innards of [clock] when it's an expected error
dict unset opts -errorinfo
return -options $opts $result
}
}
#----------------------------------------------------------------------
#
# AddMonths --
#
# Add a given number of months to a given clock value in a given
# time zone.
#
# Parameters:
# months - Number of months to add (may be negative)
# clockval - Seconds since the epoch before the operation
# timezone - Time zone in which the operation is to be performed
#
# Results:
# Returns the new clock value as a number of seconds since
# the epoch.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AddMonths { months clockval timezone changeover } {
variable DaysInRomanMonthInCommonYear
variable DaysInRomanMonthInLeapYear
variable TZData
# Convert the time to year, month, day, and fraction of day.
set date [GetDateFields $clockval $TZData($timezone) $changeover]
dict set date secondOfDay [expr {
[dict get $date localSeconds] % 86400
}]
dict set date tzName $timezone
# Add the requisite number of months
set m [dict get $date month]
incr m $months
incr m -1
set delta [expr { $m / 12 }]
set mm [expr { $m % 12 }]
dict set date month [expr { $mm + 1 }]
dict incr date year $delta
# If the date doesn't exist in the current month, repair it
if { [IsGregorianLeapYear $date] } {
set hath [lindex $DaysInRomanMonthInLeapYear $mm]
} else {
set hath [lindex $DaysInRomanMonthInCommonYear $mm]
}
if { [dict get $date dayOfMonth] > $hath } {
dict set date dayOfMonth $hath
}
# Reconvert to a number of seconds
set date [GetJulianDayFromEraYearMonthDay \
$date[set date {}]\
$changeover]
dict set date localSeconds [expr {
-210866803200
+ ( 86400 * wide([dict get $date julianDay]) )
+ [dict get $date secondOfDay]
}]
set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
$changeover]
return [dict get $date seconds]
}
#----------------------------------------------------------------------
#
# AddDays --
#
# Add a given number of days to a given clock value in a given time
# zone.
#
# Parameters:
# days - Number of days to add (may be negative)
# clockval - Seconds since the epoch before the operation
# timezone - Time zone in which the operation is to be performed
# changeover - Julian Day on which the Gregorian calendar was adopted
# in the target locale.
#
# Results:
# Returns the new clock value as a number of seconds since the epoch.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc AddDays { days clockval timezone changeover } {
variable TZData
# Convert the time to Julian Day
set date [GetDateFields $clockval $TZData($timezone) $changeover]
dict set date secondOfDay [expr {
[dict get $date localSeconds] % 86400
}]
dict set date tzName $timezone
# Add the requisite number of days
dict incr date julianDay $days
# Reconvert to a number of seconds
dict set date localSeconds [expr {
-210866803200
+ ( 86400 * wide([dict get $date julianDay]) )
+ [dict get $date secondOfDay]
}]
set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
$changeover]
return [dict get $date seconds]
}
#----------------------------------------------------------------------
#
# ChangeCurrentLocale --
#
# The global locale was changed within msgcat.
# Clears the buffered parse functions of the current locale.
#
# Parameters:
# loclist (ignored)
#
# Results:
# None.
#
# Side effects:
# Buffered parse functions are cleared.
#
#----------------------------------------------------------------------
proc ChangeCurrentLocale {args} {
variable FormatProc
variable LocaleNumeralCache
variable CachedSystemTimeZone
variable TimeZoneBad
foreach p [info procs [namespace current]::scanproc'*'current] {
rename $p {}
}
foreach p [info procs [namespace current]::formatproc'*'current] {
rename $p {}
}
catch {array unset FormatProc *'current}
set LocaleNumeralCache {}
}
#----------------------------------------------------------------------
#
# ClearCaches --
#
# Clears all caches to reclaim the memory used in [clock]
#
# Parameters:
# None.
#
# Results:
# None.
#
# Side effects:
# Caches are cleared.
#
#----------------------------------------------------------------------
proc ClearCaches {} {
variable FormatProc
variable LocaleNumeralCache
variable CachedSystemTimeZone
variable TimeZoneBad
foreach p [info procs [namespace current]::scanproc'*] {
rename $p {}
}
foreach p [info procs [namespace current]::formatproc'*] {
rename $p {}
}
catch {unset FormatProc}
set LocaleNumeralCache {}
catch {unset CachedSystemTimeZone}
set TimeZoneBad {}
InitTZData
}
|
1 2 3 4 5 | # cookiejar.tcl -- # # Implementation of an HTTP cookie storage engine using SQLite. The # implementation is done as a TclOO class, and includes a punycode # encoder and decoder (though only the encoder is currently used). | > > > > > > > > > > < < < | 1 2 3 4 5 6 7 8 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. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # cookiejar.tcl -- # # Implementation of an HTTP cookie storage engine using SQLite. The # implementation is done as a TclOO class, and includes a punycode # encoder and decoder (though only the encoder is currently used). # Dependencies package require Tcl 8.6- package require http 2.8.4 package require sqlite3 package require tcl::idna 1.0 |
| ︙ | ︙ |
1 2 3 4 5 6 | # idna.tcl -- # # Implementation of IDNA (Internationalized Domain Names for # Applications) encoding/decoding system, built on a punycode engine # developed directly from the code in RFC 3492, Appendix C (with # substantial modifications). | > > > > > > > > > > > > | | < < < < < | 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 |
# Copyright © 2014 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# idna.tcl --
#
# Implementation of IDNA (Internationalized Domain Names for
# Applications) encoding/decoding system, built on a punycode engine
# developed directly from the code in RFC 3492, Appendix C (with
# substantial modifications).
# This implementation includes code from that RFC, translated to Tcl.
namespace eval ::tcl::idna {
namespace ensemble create -command puny -map {
encode punyencode
decode punydecode
}
namespace ensemble create -command ::tcl::idna -map {
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright © 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # history.tcl -- # # Implementation of the history command. # # The tcl::history array holds the history list and some additional # bookkeeping variables. # # nextid the index used for the next history list item. # keep the max size of the history list |
| ︙ | ︙ |
1 2 3 4 5 6 | # 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. | > > > > > > > > > > < < < | 1 2 3 4 5 6 7 8 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.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.10b4
namespace eval http {
|
| ︙ | ︙ | |||
1779 1780 1781 1782 1783 1784 1785 |
##Log post socket opened, - token $token
##Log socket opened, now fconfigure - token $token
set delay [expr {[clock milliseconds] - $pre}]
if {$delay > 3000} {
Log socket delay $delay - token $token
}
fconfigure $sock -translation {auto crlf} \
| | < < < | 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 |
##Log post socket opened, - token $token
##Log socket opened, now fconfigure - token $token
set delay [expr {[clock milliseconds] - $pre}]
if {$delay > 3000} {
Log socket delay $delay - token $token
}
fconfigure $sock -translation {auto crlf} \
-buffersize $state(-blocksize) -profile strict
##Log socket opened, DONE fconfigure - token $token
}
Log "Using $sock for $state(socketinfo) - token $token" \
[expr {$state(-keepalive)?"keepalive":""}]
# Code above has set state(sock) $sock
|
| ︙ | ︙ | |||
2200 2201 2202 2203 2204 2205 2206 |
set defport [lindex $urlTypes($lower) 0]
# Send data in cr-lf format, but accept any line terminators.
# Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest.
# We are concerned here with the request (write) not the response (read).
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list $trRead crlf] \
| | < < < | 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 |
set defport [lindex $urlTypes($lower) 0]
# Send data in cr-lf format, but accept any line terminators.
# Initialisation to {auto *} now done in geturl, KeepSocket and DoneRequest.
# We are concerned here with the request (write) not the response (read).
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list $trRead crlf] \
-buffersize $state(-blocksize) -profile strict
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
catch {fconfigure $sock -blocking off}
set how GET
if {$isQuery} {
|
| ︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 |
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
| | < < < | 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 |
upvar 0 $token state
set tk [namespace tail $token]
set sock $state(sock)
#Log ---- $state(socketinfo) >> conn to $token for HTTP response
lassign [fconfigure $sock -translation] trRead trWrite
fconfigure $sock -translation [list auto $trWrite] \
-buffersize $state(-blocksize) -profile strict
Log ^D$tk begin receiving response - token $token
coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
fileevent $sock readable [list http::EventGateway $sock $token]
} else {
fileevent $sock readable ${token}--EventCoroutine
|
| ︙ | ︙ | |||
4588 4589 4590 4591 4592 4593 4594 |
# If we are getting text, set the incoming channel's encoding
# correctly. iso8859-1 is the RFC default, but this could be any
# IANA charset. However, we only know how to convert what we have
# encodings for.
set enc [CharsetToEncoding $state(charset)]
if {$enc ne "binary"} {
| < | < | < | 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 |
# If we are getting text, set the incoming channel's encoding
# correctly. iso8859-1 is the RFC default, but this could be any
# IANA charset. However, we only know how to convert what we have
# encodings for.
set enc [CharsetToEncoding $state(charset)]
if {$enc ne "binary"} {
set state(body) [
encoding convertfrom -profile strict $enc $state(body)]
}
# Translate text line endings.
set state(body) [string map {\r\n \n \r \n} $state(body)]
}
if {[info exists state(-guesstype)] && $state(-guesstype)} {
GuessType $token
|
| ︙ | ︙ | |||
4675 4676 4677 4678 4679 4680 4681 |
set res $value
}
}
set enc [CharsetToEncoding $res]
if {$enc eq "binary"} {
return 0
}
| < | < < < | 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 |
set res $value
}
}
set enc [CharsetToEncoding $res]
if {$enc eq "binary"} {
return 0
}
set state(body) [encoding convertfrom -profile strict $enc $state(body)]
set state(body) [string map {\r\n \n \r \n} $state(body)]
set state(type) application/xml
set state(binary) 0
set state(charset) $res
return 1
}
|
| ︙ | ︙ | |||
4760 4761 4762 4763 4764 4765 4766 |
variable http
variable formMap
# The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
# a pre-computed map and [string map] to do the conversion (much faster
# than [regsub]/[subst]). [Bug 1020491]
| < | < < < | 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 |
variable http
variable formMap
# The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
# a pre-computed map and [string map] to do the conversion (much faster
# than [regsub]/[subst]). [Bug 1020491]
set string [encoding convertto -profile strict $http(-urlencoding) $string]
return [string map $formMap $string]
}
# http::ProxyRequired --
# Default proxy filter.
#
# Arguments:
|
| ︙ | ︙ |
|
| < < < < < | > > > > > > > > > > > > | 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 | # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # Copyright © 2004 Kevin B. Kenny. # Copyright © 2018 Sean Woods # # All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Copyright © 2004 Nathan Coulter # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. package require -exact tcl 9.0b4 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH |
| ︙ | ︙ | |||
102 103 104 105 106 107 108 109 110 111 112 |
if {$tcl_platform(os) eq "Darwin"
&& $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
apply {{} {
| > | | < | | > > > > | > | | > > > > > > > > > > > > > > > > > > > | 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 |
if {$tcl_platform(os) eq "Darwin"
&& $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
apply {{} {
namespace export add classic clicks format microseconds \
milliseconds scan seconds
namespace ensemble create -command ::clock -unknown [
list ::apply [list args {
source [file join $::tcl_library clock.tcl]
return
} ::tcl::clock]]
::tcl::unsupported::clock::configure -init-complete
} ::tcl::clock}
# Set up the 'clockclassic' ensemble
namespace eval ::tcl::clock::classic [list variable TclLibDir $::tcl_library]
apply [list {} {
# Auto-loading stubs for 'clockclassic.tcl'
foreach cmd {add format scan} {
proc $cmd args {
variable TclLibDir
source [file join $TclLibDir clockclassic.tcl]
return [uplevel 1 [info level 0]]
}
}
namespace eval [namespace parent] {
namespace export classic
}
} ::tcl::clock::classic]
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
# Some machines do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | history change $newcmd 0 uplevel 1 [list ::catch $newcmd \ ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } | | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
history change $newcmd 0
uplevel 1 [list ::catch $newcmd \
::tcl::UnknownResult ::tcl::UnknownOptions]
dict incr ::tcl::UnknownOptions -level
return -options $::tcl::UnknownOptions $::tcl::UnknownResult
}
set ret [catch [list uplevel 1 [list ::info commands $name*]] candidates]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
dict append opts -errorinfo \
"\n (expanding command prefix \"$name\" in unknown)"
return -options $opts $candidates
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
###
# Installer actions built into tclsh and invoked
# if the first command line argument is "install"
###
if {[llength $argv] < 2} {
exit 0
}
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
###
# Installer actions built into tclsh and invoked
# if the first command line argument is "install"
###
if {[llength $argv] < 2} {
exit 0
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 2010-2018 Harald Oehlmann. # Copyright © 1998-2000 Ajuba Solutions. # Copyright © 1998 Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # msgcat.tcl -- # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # We use oo::define::self, which is new in Tcl 8.7 package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.1 |
| ︙ | ︙ |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset af DAYS_OF_WEEK_ABBREV [list \ "So"\ "Ma"\ "Di"\ "Wo"\ "Do"\ "Vr"\ "Sa"] ::msgcat::mcset af DAYS_OF_WEEK_FULL [list \ "Sondag"\ "Maandag"\ "Dinsdag"\ "Woensdag"\ "Donderdag"\ "Vrydag"\ "Saterdag"] ::msgcat::mcset af MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mar"\ "Apr"\ "Mei"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Des"\ ""] ::msgcat::mcset af MONTHS_FULL [list \ "Januarie"\ "Februarie"\ "Maart"\ "April"\ "Mei"\ "Junie"\ "Julie"\ "Augustus"\ "September"\ "Oktober"\ "November"\ "Desember"\ ""] ::msgcat::mcset af AM "VM" ::msgcat::mcset af PM "NM" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset af_ZA DATE_FORMAT "%d %B %Y" ::msgcat::mcset af_ZA TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset af_ZA DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ar DAYS_OF_WEEK_ABBREV [list \ "ح"\ "ن"\ "ث"\ "ر"\ "خ"\ "ج"\ "س"] ::msgcat::mcset ar DAYS_OF_WEEK_FULL [list \ "الأحد"\ "الاثنين"\ "الثلاثاء"\ "الأربعاء"\ "الخميس"\ "الجمعة"\ "السبت"] ::msgcat::mcset ar MONTHS_ABBREV [list \ "ينا"\ "فبر"\ "مار"\ "أبر"\ "ماي"\ "يون"\ "يول"\ "أغس"\ "سبت"\ "أكت"\ "نوف"\ "ديس"\ ""] ::msgcat::mcset ar MONTHS_FULL [list \ "يناير"\ "فبراير"\ "مارس"\ "أبريل"\ "مايو"\ "يونيو"\ "يوليو"\ "أغسطس"\ "سبتمبر"\ "أكتوبر"\ "نوفمبر"\ "ديسمبر"\ ""] ::msgcat::mcset ar BCE "ق.م" ::msgcat::mcset ar CE "م" ::msgcat::mcset ar AM "ص" ::msgcat::mcset ar PM "م" ::msgcat::mcset ar DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset ar TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset ar DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ar_IN DATE_FORMAT "%A %d %B %Y" ::msgcat::mcset ar_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset ar_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ar_JO DAYS_OF_WEEK_ABBREV [list \ "الأحد"\ "الاثنين"\ "الثلاثاء"\ "الأربعاء"\ "الخميس"\ "الجمعة"\ "السبت"] ::msgcat::mcset ar_JO MONTHS_ABBREV [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نوار"\ "حزيران"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] ::msgcat::mcset ar_JO MONTHS_FULL [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نوار"\ "حزيران"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ar_LB DAYS_OF_WEEK_ABBREV [list \ "الأحد"\ "الاثنين"\ "الثلاثاء"\ "الأربعاء"\ "الخميس"\ "الجمعة"\ "السبت"] ::msgcat::mcset ar_LB MONTHS_ABBREV [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نوار"\ "حزيران"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] ::msgcat::mcset ar_LB MONTHS_FULL [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نوار"\ "حزيران"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ar_SY DAYS_OF_WEEK_ABBREV [list \ "الأحد"\ "الاثنين"\ "الثلاثاء"\ "الأربعاء"\ "الخميس"\ "الجمعة"\ "السبت"] ::msgcat::mcset ar_SY MONTHS_ABBREV [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نوار"\ "حزيران"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] ::msgcat::mcset ar_SY MONTHS_FULL [list \ "كانون الثاني"\ "شباط"\ "آذار"\ "نيسان"\ "نواران"\ "حزير"\ "تموز"\ "آب"\ "أيلول"\ "تشرين الأول"\ "تشرين الثاني"\ "كانون الأول"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset be DAYS_OF_WEEK_ABBREV [list \ "нд"\ "пн"\ "ат"\ "ср"\ "чц"\ "пт"\ "сб"] ::msgcat::mcset be DAYS_OF_WEEK_FULL [list \ "нядзеля"\ "панядзелак"\ "аўторак"\ "серада"\ "чацвер"\ "пятніца"\ "субота"] ::msgcat::mcset be MONTHS_ABBREV [list \ "стд"\ "лют"\ "скв"\ "крс"\ "май"\ "чрв"\ "лпн"\ "жнв"\ "врс"\ "кст"\ "лст"\ "снж"\ ""] ::msgcat::mcset be MONTHS_FULL [list \ "студзеня"\ "лютага"\ "сакавіка"\ "красавіка"\ "мая"\ "чрвеня"\ "ліпеня"\ "жніўня"\ "верасня"\ "кастрычніка"\ "листапада"\ "снежня"\ ""] ::msgcat::mcset be BCE "да н.е." ::msgcat::mcset be CE "н.е." ::msgcat::mcset be DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset be TIME_FORMAT "%k.%M.%S" ::msgcat::mcset be DATE_TIME_FORMAT "%e.%m.%Y %k.%M.%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset bg DAYS_OF_WEEK_ABBREV [list \ "Нд"\ "Пн"\ "Вт"\ "Ср"\ "Чт"\ "Пт"\ "Сб"] ::msgcat::mcset bg DAYS_OF_WEEK_FULL [list \ "Неделя"\ "Понеделник"\ "Вторник"\ "Сряда"\ "Четвъртък"\ "Петък"\ "Събота"] ::msgcat::mcset bg MONTHS_ABBREV [list \ "I"\ "II"\ "III"\ "IV"\ "V"\ "VI"\ "VII"\ "VIII"\ "IX"\ "X"\ "XI"\ "XII"\ ""] ::msgcat::mcset bg MONTHS_FULL [list \ "Януари"\ "Февруари"\ "Март"\ "Април"\ "Май"\ "Юни"\ "Юли"\ "Август"\ "Септември"\ "Октомври"\ "Ноември"\ "Декември"\ ""] ::msgcat::mcset bg BCE "пр.н.е." ::msgcat::mcset bg CE "н.е." ::msgcat::mcset bg DATE_FORMAT "%Y-%m-%e" ::msgcat::mcset bg TIME_FORMAT "%k:%M:%S" ::msgcat::mcset bg DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset bn DAYS_OF_WEEK_ABBREV [list \ "রবি"\ "সোম"\ "মঙগল"\ "বুধ"\ "বৃহস্পতি"\ "শুক্র"\ "শনি"] ::msgcat::mcset bn DAYS_OF_WEEK_FULL [list \ "রবিবার"\ "সোমবার"\ "মঙগলবার"\ "বুধবার"\ "বৃহস্পতিবার"\ "শুক্রবার"\ "শনিবার"] ::msgcat::mcset bn MONTHS_ABBREV [list \ "জানুয়ারী"\ "ফেব্রুয়ারী"\ "মার্চ"\ "এপ্রিল"\ "মে"\ "জুন"\ "জুলাই"\ "আগস্ট"\ "সেপ্টেম্বর"\ "অক্টোবর"\ "নভেম্বর"\ "ডিসেম্বর"\ ""] ::msgcat::mcset bn MONTHS_FULL [list \ "জানুয়ারী"\ "ফেব্রুয়ারী"\ "মার্চ"\ "এপ্রিল"\ "মে"\ "জুন"\ "জুলাই"\ "আগস্ট"\ "সেপ্টেম্বর"\ "অক্টোবর"\ "নভেম্বর"\ "ডিসেম্বর"\ ""] ::msgcat::mcset bn AM "পূর্বাহ্ণ" ::msgcat::mcset bn PM "অপরাহ্ণ" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset bn_IN DATE_FORMAT "%A %d %b %Y" ::msgcat::mcset bn_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset bn_IN DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ca DAYS_OF_WEEK_ABBREV [list \ "dg."\ "dl."\ "dt."\ "dc."\ "dj."\ "dv."\ "ds."] ::msgcat::mcset ca DAYS_OF_WEEK_FULL [list \ "diumenge"\ "dilluns"\ "dimarts"\ "dimecres"\ "dijous"\ "divendres"\ "dissabte"] ::msgcat::mcset ca MONTHS_ABBREV [list \ "gen."\ "feb."\ "març"\ "abr."\ "maig"\ "juny"\ "jul."\ "ag."\ "set."\ "oct."\ "nov."\ "des."\ ""] ::msgcat::mcset ca MONTHS_FULL [list \ "gener"\ "febrer"\ "març"\ "abril"\ "maig"\ "juny"\ "juliol"\ "agost"\ "setembre"\ "octubre"\ "novembre"\ "desembre"\ ""] ::msgcat::mcset ca DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset ca TIME_FORMAT "%H:%M:%S" ::msgcat::mcset ca DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset cs DAYS_OF_WEEK_ABBREV [list \ "Ne"\ "Po"\ "Út"\ "St"\ "Čt"\ "Pá"\ "So"] ::msgcat::mcset cs DAYS_OF_WEEK_FULL [list \ "Neděle"\ "Pondělí"\ "Úterý"\ "Středa"\ "Čtvrtek"\ "Pátek"\ "Sobota"] ::msgcat::mcset cs MONTHS_ABBREV [list \ "I"\ "II"\ "III"\ "IV"\ "V"\ "VI"\ "VII"\ "VIII"\ "IX"\ "X"\ "XI"\ "XII"\ ""] ::msgcat::mcset cs MONTHS_FULL [list \ "leden"\ "únor"\ "březen"\ "duben"\ "květen"\ "červen"\ "červenec"\ "srpen"\ "září"\ "říjen"\ "listopad"\ "prosinec"\ ""] ::msgcat::mcset cs BCE "př.Kr." ::msgcat::mcset cs CE "po Kr." ::msgcat::mcset cs AM "dop." ::msgcat::mcset cs PM "odp." ::msgcat::mcset cs DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset cs TIME_FORMAT "%k:%M:%S" ::msgcat::mcset cs DATE_TIME_FORMAT "%e.%m.%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset da DAYS_OF_WEEK_ABBREV [list \ "sø"\ "ma"\ "ti"\ "on"\ "to"\ "fr"\ "lø"] ::msgcat::mcset da DAYS_OF_WEEK_FULL [list \ "søndag"\ "mandag"\ "tirsdag"\ "onsdag"\ "torsdag"\ "fredag"\ "lørdag"] ::msgcat::mcset da MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset da MONTHS_FULL [list \ "januar"\ "februar"\ "marts"\ "april"\ "maj"\ "juni"\ "juli"\ "august"\ "september"\ "oktober"\ "november"\ "december"\ ""] ::msgcat::mcset da BCE "f.Kr." ::msgcat::mcset da CE "e.Kr." ::msgcat::mcset da DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset da TIME_FORMAT "%H:%M:%S" ::msgcat::mcset da DATE_TIME_FORMAT "%d-%m-%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset de DAYS_OF_WEEK_ABBREV [list \ "So"\ "Mo"\ "Di"\ "Mi"\ "Do"\ "Fr"\ "Sa"] ::msgcat::mcset de DAYS_OF_WEEK_FULL [list \ "Sonntag"\ "Montag"\ "Dienstag"\ "Mittwoch"\ "Donnerstag"\ "Freitag"\ "Samstag"] ::msgcat::mcset de MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mrz"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de MONTHS_FULL [list \ "Januar"\ "Februar"\ "März"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ "September"\ "Oktober"\ "November"\ "Dezember"\ ""] ::msgcat::mcset de BCE "v. Chr." ::msgcat::mcset de CE "n. Chr." ::msgcat::mcset de AM "vorm." ::msgcat::mcset de PM "nachm." ::msgcat::mcset de DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset de TIME_FORMAT "%H:%M:%S" ::msgcat::mcset de DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset de_AT MONTHS_ABBREV [list \ "Jän"\ "Feb"\ "Mär"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de_AT MONTHS_FULL [list \ "Jänner"\ "Februar"\ "März"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ "September"\ "Oktober"\ "November"\ "Dezember"\ ""] ::msgcat::mcset de_AT DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset de_AT TIME_FORMAT "%T" ::msgcat::mcset de_AT TIME_FORMAT_12 "%T" ::msgcat::mcset de_AT DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset de_BE DAYS_OF_WEEK_ABBREV [list \ "Son"\ "Mon"\ "Die"\ "Mit"\ "Don"\ "Fre"\ "Sam"] ::msgcat::mcset de_BE DAYS_OF_WEEK_FULL [list \ "Sonntag"\ "Montag"\ "Dienstag"\ "Mittwoch"\ "Donnerstag"\ "Freitag"\ "Samstag"] ::msgcat::mcset de_BE MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mär"\ "Apr"\ "Mai"\ "Jun"\ "Jul"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset de_BE MONTHS_FULL [list \ "Januar"\ "Februar"\ "März"\ "April"\ "Mai"\ "Juni"\ "Juli"\ "August"\ "September"\ "Oktober"\ "November"\ "Dezember"\ ""] ::msgcat::mcset de_BE AM "vorm" ::msgcat::mcset de_BE PM "nachm" ::msgcat::mcset de_BE DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset de_BE TIME_FORMAT "%T" ::msgcat::mcset de_BE TIME_FORMAT_12 "%T" ::msgcat::mcset de_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset el DAYS_OF_WEEK_ABBREV [list \ "Κυρ"\ "Δευ"\ "Τρι"\ "Τετ"\ "Πεμ"\ "Παρ"\ "Σαβ"] ::msgcat::mcset el DAYS_OF_WEEK_FULL [list \ "Κυριακή"\ "Δευτέρα"\ "Τρίτη"\ "Τετάρτη"\ "Πέμπτη"\ "Παρασκευή"\ "Σάββατο"] ::msgcat::mcset el MONTHS_ABBREV [list \ "Ιαν"\ "Φεβ"\ "Μαρ"\ "Απρ"\ "Μαϊ"\ "Ιουν"\ "Ιουλ"\ "Αυγ"\ "Σεπ"\ "Οκτ"\ "Νοε"\ "Δεκ"\ ""] ::msgcat::mcset el MONTHS_FULL [list \ "Ιανουάριος"\ "Φεβρουάριος"\ "Μάρτιος"\ "Απρίλιος"\ "Μάϊος"\ "Ιούνιος"\ "Ιούλιος"\ "Αύγουστος"\ "Σεπτέμβριος"\ "Οκτώβριος"\ "Νοέμβριος"\ "Δεκέμβριος"\ ""] ::msgcat::mcset el AM "πμ" ::msgcat::mcset el PM "μμ" ::msgcat::mcset el DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset el TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset el DATE_TIME_FORMAT "%e/%m/%Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_AU DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset en_AU TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_AU TIME_FORMAT_12 "%I:%M:%S %P %z" ::msgcat::mcset en_AU DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_BE DATE_FORMAT "%d %b %Y" ::msgcat::mcset en_BE TIME_FORMAT "%k:%M:%S" ::msgcat::mcset en_BE TIME_FORMAT_12 "%k h %M min %S s %z" ::msgcat::mcset en_BE DATE_TIME_FORMAT "%d %b %Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_BW DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_BW TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_BW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_CA DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_CA TIME_FORMAT "%r" ::msgcat::mcset en_CA TIME_FORMAT_12 "%I:%M:%S %p" ::msgcat::mcset en_CA DATE_TIME_FORMAT "%a %d %b %Y %r %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_GB DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_GB TIME_FORMAT "%T" ::msgcat::mcset en_GB TIME_FORMAT_12 "%T" ::msgcat::mcset en_GB DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_HK AM "AM" ::msgcat::mcset en_HK PM "PM" ::msgcat::mcset en_HK DATE_FORMAT "%B %e, %Y" ::msgcat::mcset en_HK TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_HK DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_IE DATE_FORMAT "%d/%m/%y" ::msgcat::mcset en_IE TIME_FORMAT "%T" ::msgcat::mcset en_IE TIME_FORMAT_12 "%T" ::msgcat::mcset en_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_IN AM "AM" ::msgcat::mcset en_IN PM "PM" ::msgcat::mcset en_IN DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_IN TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_IN DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_NZ DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset en_NZ TIME_FORMAT "%H:%M:%S" ::msgcat::mcset en_NZ TIME_FORMAT_12 "%I:%M:%S %P %z" ::msgcat::mcset en_NZ DATE_TIME_FORMAT "%e/%m/%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_PH AM "AM" ::msgcat::mcset en_PH PM "PM" ::msgcat::mcset en_PH DATE_FORMAT "%B %e, %Y" ::msgcat::mcset en_PH TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_PH DATE_TIME_FORMAT "%B %e, %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_SG DATE_FORMAT "%d %b %Y" ::msgcat::mcset en_SG TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset en_SG DATE_TIME_FORMAT "%d %b %Y %P %I:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_ZA DATE_FORMAT "%Y/%m/%d" ::msgcat::mcset en_ZA TIME_FORMAT_12 "%I:%M:%S" ::msgcat::mcset en_ZA DATE_TIME_FORMAT "%Y/%m/%d %I:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset en_ZW DATE_FORMAT "%d %B %Y" ::msgcat::mcset en_ZW TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset en_ZW DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset eo DAYS_OF_WEEK_ABBREV [list \ "di"\ "lu"\ "ma"\ "me"\ "ĵa"\ "ve"\ "sa"] ::msgcat::mcset eo DAYS_OF_WEEK_FULL [list \ "dimanĉo"\ "lundo"\ "mardo"\ "merkredo"\ "ĵaŭdo"\ "vendredo"\ "sabato"] ::msgcat::mcset eo MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ "aŭg"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset eo MONTHS_FULL [list \ "januaro"\ "februaro"\ "marto"\ "aprilo"\ "majo"\ "junio"\ "julio"\ "aŭgusto"\ "septembro"\ "oktobro"\ "novembro"\ "decembro"\ ""] ::msgcat::mcset eo BCE "aK" ::msgcat::mcset eo CE "pK" ::msgcat::mcset eo AM "atm" ::msgcat::mcset eo PM "ptm" ::msgcat::mcset eo DATE_FORMAT "%Y-%b-%d" ::msgcat::mcset eo TIME_FORMAT "%H:%M:%S" ::msgcat::mcset eo DATE_TIME_FORMAT "%Y-%b-%d %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es DAYS_OF_WEEK_ABBREV [list \ "dom"\ "lun"\ "mar"\ "mié"\ "jue"\ "vie"\ "sáb"] ::msgcat::mcset es DAYS_OF_WEEK_FULL [list \ "domingo"\ "lunes"\ "martes"\ "miércoles"\ "jueves"\ "viernes"\ "sábado"] ::msgcat::mcset es MONTHS_ABBREV [list \ "ene"\ "feb"\ "mar"\ "abr"\ "may"\ "jun"\ "jul"\ "ago"\ "sep"\ "oct"\ "nov"\ "dic"\ ""] ::msgcat::mcset es MONTHS_FULL [list \ "enero"\ "febrero"\ "marzo"\ "abril"\ "mayo"\ "junio"\ "julio"\ "agosto"\ "septiembre"\ "octubre"\ "noviembre"\ "diciembre"\ ""] ::msgcat::mcset es BCE "a.C." ::msgcat::mcset es CE "d.C." ::msgcat::mcset es DATE_FORMAT "%e de %B de %Y" ::msgcat::mcset es TIME_FORMAT "%k:%M:%S" ::msgcat::mcset es DATE_TIME_FORMAT "%e de %B de %Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_AR DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_AR TIME_FORMAT "%H:%M:%S" ::msgcat::mcset es_AR DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_BO DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset es_BO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_BO DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_CL DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset es_CL TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CL DATE_TIME_FORMAT "%d-%m-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_CO DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_CO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CO DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_CR DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_CR TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_CR DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_DO DATE_FORMAT "%m/%d/%Y" ::msgcat::mcset es_DO TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_DO DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_EC DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_EC TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_EC DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_GT DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_GT TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_GT DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_HN DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_HN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_HN DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_MX DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset es_MX TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_MX DATE_TIME_FORMAT "%e/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_NI DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_NI TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_NI DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_PA DATE_FORMAT "%m/%d/%Y" ::msgcat::mcset es_PA TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PA DATE_TIME_FORMAT "%m/%d/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_PE DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_PE TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_PR DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_PR TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PR DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_PY DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_PY TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_PY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_SV DATE_FORMAT "%m-%d-%Y" ::msgcat::mcset es_SV TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_SV DATE_TIME_FORMAT "%m-%d-%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_UY DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_UY TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_UY DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset es_VE DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset es_VE TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset es_VE DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset et DAYS_OF_WEEK_ABBREV [list \ "P"\ "E"\ "T"\ "K"\ "N"\ "R"\ "L"] ::msgcat::mcset et DAYS_OF_WEEK_FULL [list \ "pühapäev"\ "esmaspäev"\ "teisipäev"\ "kolmapäev"\ "neljapäev"\ "reede"\ "laupäev"] ::msgcat::mcset et MONTHS_ABBREV [list \ "Jaan"\ "Veebr"\ "Märts"\ "Apr"\ "Mai"\ "Juuni"\ "Juuli"\ "Aug"\ "Sept"\ "Okt"\ "Nov"\ "Dets"\ ""] ::msgcat::mcset et MONTHS_FULL [list \ "Jaanuar"\ "Veebruar"\ "Märts"\ "Aprill"\ "Mai"\ "Juuni"\ "Juuli"\ "August"\ "September"\ "Oktoober"\ "November"\ "Detsember"\ ""] ::msgcat::mcset et BCE "e.m.a." ::msgcat::mcset et CE "m.a.j." ::msgcat::mcset et DATE_FORMAT "%e-%m-%Y" ::msgcat::mcset et TIME_FORMAT "%k:%M:%S" ::msgcat::mcset et DATE_TIME_FORMAT "%e-%m-%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset eu DAYS_OF_WEEK_ABBREV [list \ "igandea"\ "astelehena"\ "asteartea"\ "asteazkena"\ "osteguna"\ "ostirala"\ "larunbata"] ::msgcat::mcset eu DAYS_OF_WEEK_FULL [list \ "igandea"\ "astelehena"\ "asteartea"\ "asteazkena"\ "osteguna"\ "ostirala"\ "larunbata"] ::msgcat::mcset eu MONTHS_ABBREV [list \ "urt"\ "ots"\ "mar"\ "api"\ "mai"\ "eka"\ "uzt"\ "abu"\ "ira"\ "urr"\ "aza"\ "abe"\ ""] ::msgcat::mcset eu MONTHS_FULL [list \ "urtarrila"\ "otsaila"\ "martxoa"\ "apirila"\ "maiatza"\ "ekaina"\ "uztaila"\ "abuztua"\ "iraila"\ "urria"\ "azaroa"\ "abendua"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset eu_ES DATE_FORMAT "%a, %Yeko %bren %da" ::msgcat::mcset eu_ES TIME_FORMAT "%T" ::msgcat::mcset eu_ES TIME_FORMAT_12 "%T" ::msgcat::mcset eu_ES DATE_TIME_FORMAT "%y-%m-%d %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fa DAYS_OF_WEEK_ABBREV [list \ "ی∔"\ "د∔"\ "س∔"\ "چ∔"\ "پ∔"\ "ج∔"\ "ش∔"] ::msgcat::mcset fa DAYS_OF_WEEK_FULL [list \ "ییشنبه"\ "دوشنبه"\ "سهشنبه"\ "چهارشنبه"\ "پنجشنبه"\ "جمعه"\ "شنبه"] ::msgcat::mcset fa MONTHS_ABBREV [list \ "ژان"\ "فور"\ "مار"\ "آور"\ "مـه"\ "ژون"\ "ژوی"\ "اوت"\ "سپت"\ "اكت"\ "نوا"\ "دسا"\ ""] ::msgcat::mcset fa MONTHS_FULL [list \ "ژانویه"\ "فورویه"\ "مارس"\ "آوریل"\ "مه"\ "ژوئن"\ "ژوئیه"\ "اوت"\ "سپتامبر"\ "اكتبر"\ "نوامبر"\ "دسامبر"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fa_IN DAYS_OF_WEEK_ABBREV [list \ "ی∔"\ "د∔"\ "س∔"\ "چ∔"\ "پ∔"\ "ج∔"\ "ش∔"] ::msgcat::mcset fa_IN DAYS_OF_WEEK_FULL [list \ "ییشنبه"\ "دوشنبه"\ "سهشنبه"\ "چهارشنبه"\ "پنجشنبه"\ "جمعه"\ "شنبه"] ::msgcat::mcset fa_IN MONTHS_ABBREV [list \ "ژان"\ "فور"\ "مار"\ "آور"\ "مـه"\ "ژون"\ "ژوی"\ "اوت"\ "سپت"\ "اكت"\ "نوا"\ "دسا"\ ""] ::msgcat::mcset fa_IN MONTHS_FULL [list \ "ژانویه"\ "فورویه"\ "مارس"\ "آوریل"\ "مه"\ "ژوئن"\ "ژوئیه"\ "اوت"\ "سپتامبر"\ "اكتبر"\ "نوامبر"\ "دسامبر"\ ""] ::msgcat::mcset fa_IN AM "صبح" ::msgcat::mcset fa_IN PM "عصر" ::msgcat::mcset fa_IN DATE_FORMAT "%A %d %B %Y" ::msgcat::mcset fa_IN TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset fa_IN DATE_TIME_FORMAT "%A %d %B %Y %I:%M:%S %z %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | < | 1 2 3 4 5 6 7 8 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fa_IR AM "صبح" ::msgcat::mcset fa_IR PM "عصر" ::msgcat::mcset fa_IR DATE_FORMAT "%d⁄%m⁄%Y" ::msgcat::mcset fa_IR TIME_FORMAT "%S:%M:%H" ::msgcat::mcset fa_IR TIME_FORMAT_12 "%S:%M:%l %P" ::msgcat::mcset fa_IR DATE_TIME_FORMAT "%d⁄%m⁄%Y %S:%M:%H %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fi DAYS_OF_WEEK_ABBREV [list \ "su"\ "ma"\ "ti"\ "ke"\ "to"\ "pe"\ "la"] ::msgcat::mcset fi DAYS_OF_WEEK_FULL [list \ "sunnuntai"\ "maanantai"\ "tiistai"\ "keskiviikko"\ "torstai"\ "perjantai"\ "lauantai"] ::msgcat::mcset fi MONTHS_ABBREV [list \ "tammi"\ "helmi"\ "maalis"\ "huhti"\ "touko"\ "kesä"\ "heinä"\ "elo"\ "syys"\ "loka"\ "marras"\ "joulu"\ ""] ::msgcat::mcset fi MONTHS_FULL [list \ "tammikuu"\ "helmikuu"\ "maaliskuu"\ "huhtikuu"\ "toukokuu"\ "kesäkuu"\ "heinäkuu"\ "elokuu"\ "syyskuu"\ "lokakuu"\ "marraskuu"\ "joulukuu"\ ""] ::msgcat::mcset fi DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset fi TIME_FORMAT "%k:%M:%S" ::msgcat::mcset fi DATE_TIME_FORMAT "%e.%m.%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fo DAYS_OF_WEEK_ABBREV [list \ "sun"\ "mán"\ "týs"\ "mik"\ "hós"\ "frí"\ "ley"] ::msgcat::mcset fo DAYS_OF_WEEK_FULL [list \ "sunnudagur"\ "mánadagur"\ "týsdagur"\ "mikudagur"\ "hósdagur"\ "fríggjadagur"\ "leygardagur"] ::msgcat::mcset fo MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "mai"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "des"\ ""] ::msgcat::mcset fo MONTHS_FULL [list \ "januar"\ "februar"\ "mars"\ "apríl"\ "mai"\ "juni"\ "juli"\ "august"\ "september"\ "oktober"\ "november"\ "desember"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fo_FO DATE_FORMAT "%d/%m-%Y" ::msgcat::mcset fo_FO TIME_FORMAT "%T" ::msgcat::mcset fo_FO TIME_FORMAT_12 "%T" ::msgcat::mcset fo_FO DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fr DAYS_OF_WEEK_ABBREV [list \ "dim."\ "lun."\ "mar."\ "mer."\ "jeu."\ "ven."\ "sam."] ::msgcat::mcset fr DAYS_OF_WEEK_FULL [list \ "dimanche"\ "lundi"\ "mardi"\ "mercredi"\ "jeudi"\ "vendredi"\ "samedi"] ::msgcat::mcset fr MONTHS_ABBREV [list \ "janv."\ "févr."\ "mars"\ "avr."\ "mai"\ "juin"\ "juil."\ "août"\ "sept."\ "oct."\ "nov."\ "déc."\ ""] ::msgcat::mcset fr MONTHS_FULL [list \ "janvier"\ "février"\ "mars"\ "avril"\ "mai"\ "juin"\ "juillet"\ "août"\ "septembre"\ "octobre"\ "novembre"\ "décembre"\ ""] ::msgcat::mcset fr BCE "av. J.-C." ::msgcat::mcset fr CE "ap. J.-C." ::msgcat::mcset fr DATE_FORMAT "%e %B %Y" ::msgcat::mcset fr TIME_FORMAT "%H:%M:%S" ::msgcat::mcset fr DATE_TIME_FORMAT "%e %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fr_BE DATE_FORMAT "%d/%m/%y" ::msgcat::mcset fr_BE TIME_FORMAT "%T" ::msgcat::mcset fr_BE TIME_FORMAT_12 "%T" ::msgcat::mcset fr_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fr_CA DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset fr_CA TIME_FORMAT "%T" ::msgcat::mcset fr_CA TIME_FORMAT_12 "%T" ::msgcat::mcset fr_CA DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset fr_CH DATE_FORMAT "%d. %m. %y" ::msgcat::mcset fr_CH TIME_FORMAT "%T" ::msgcat::mcset fr_CH TIME_FORMAT_12 "%T" ::msgcat::mcset fr_CH DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ga DAYS_OF_WEEK_ABBREV [list \ "Domh"\ "Luan"\ "Máirt"\ "Céad"\ "Déar"\ "Aoine"\ "Sath"] ::msgcat::mcset ga DAYS_OF_WEEK_FULL [list \ "Dé Domhnaigh"\ "Dé Luain"\ "Dé Máirt"\ "Dé Céadaoin"\ "Déardaoin"\ "Dé hAoine"\ "Dé Sathairn"] ::msgcat::mcset ga MONTHS_ABBREV [list \ "Ean"\ "Feabh"\ "Márta"\ "Aib"\ "Beal"\ "Meith"\ "Iúil"\ "Lún"\ "MFómh"\ "DFómh"\ "Samh"\ "Noll"\ ""] ::msgcat::mcset ga MONTHS_FULL [list \ "Eanáir"\ "Feabhra"\ "Márta"\ "Aibreán"\ "Mí na Bealtaine"\ "Meith"\ "Iúil"\ "Lúnasa"\ "Meán Fómhair"\ "Deireadh Fómhair"\ "Mí na Samhna"\ "Mí na Nollag"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ga_IE DATE_FORMAT "%d.%m.%y" ::msgcat::mcset ga_IE TIME_FORMAT "%T" ::msgcat::mcset ga_IE TIME_FORMAT_12 "%T" ::msgcat::mcset ga_IE DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset gl DAYS_OF_WEEK_ABBREV [list \ "Dom"\ "Lun"\ "Mar"\ "Mér"\ "Xov"\ "Ven"\ "Sáb"] ::msgcat::mcset gl DAYS_OF_WEEK_FULL [list \ "Domingo"\ "Luns"\ "Martes"\ "Mércores"\ "Xoves"\ "Venres"\ "Sábado"] ::msgcat::mcset gl MONTHS_ABBREV [list \ "Xan"\ "Feb"\ "Mar"\ "Abr"\ "Mai"\ "Xuñ"\ "Xul"\ "Ago"\ "Set"\ "Out"\ "Nov"\ "Dec"\ ""] ::msgcat::mcset gl MONTHS_FULL [list \ "Xaneiro"\ "Febreiro"\ "Marzo"\ "Abril"\ "Maio"\ "Xuño"\ "Xullo"\ "Agosto"\ "Setembro"\ "Outubro"\ "Novembro"\ "Decembro"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset gl_ES DATE_FORMAT "%d %B %Y" ::msgcat::mcset gl_ES TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset gl_ES DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset gv DAYS_OF_WEEK_ABBREV [list \ "Jed"\ "Jel"\ "Jem"\ "Jerc"\ "Jerd"\ "Jeh"\ "Jes"] ::msgcat::mcset gv DAYS_OF_WEEK_FULL [list \ "Jedoonee"\ "Jelhein"\ "Jemayrt"\ "Jercean"\ "Jerdein"\ "Jeheiney"\ "Jesarn"] ::msgcat::mcset gv MONTHS_ABBREV [list \ "J-guer"\ "T-arree"\ "Mayrnt"\ "Avrril"\ "Boaldyn"\ "M-souree"\ "J-souree"\ "Luanistyn"\ "M-fouyir"\ "J-fouyir"\ "M.Houney"\ "M.Nollick"\ ""] ::msgcat::mcset gv MONTHS_FULL [list \ "Jerrey-geuree"\ "Toshiaght-arree"\ "Mayrnt"\ "Averil"\ "Boaldyn"\ "Mean-souree"\ "Jerrey-souree"\ "Luanistyn"\ "Mean-fouyir"\ "Jerrey-fouyir"\ "Mee Houney"\ "Mee ny Nollick"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset gv_GB DATE_FORMAT "%d %B %Y" ::msgcat::mcset gv_GB TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset gv_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset he DAYS_OF_WEEK_ABBREV [list \ "א"\ "ב"\ "ג"\ "ד"\ "ה"\ "ו"\ "ש"] ::msgcat::mcset he DAYS_OF_WEEK_FULL [list \ "יום ראשון"\ "יום שני"\ "יום שלישי"\ "יום רביעי"\ "יום חמישי"\ "יום שישי"\ "שבת"] ::msgcat::mcset he MONTHS_ABBREV [list \ "ינו"\ "פבר"\ "מרץ"\ "אפר"\ "מאי"\ "יונ"\ "יול"\ "אוג"\ "ספט"\ "אוק"\ "נוב"\ "דצמ"\ ""] ::msgcat::mcset he MONTHS_FULL [list \ "ינואר"\ "פברואר"\ "מרץ"\ "אפריל"\ "מאי"\ "יוני"\ "יולי"\ "אוגוסט"\ "ספטמבר"\ "אוקטובר"\ "נובמבר"\ "דצמבר"\ ""] ::msgcat::mcset he BCE "לסה"נ" ::msgcat::mcset he CE "לפסה"נ" ::msgcat::mcset he DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset he TIME_FORMAT "%H:%M:%S" ::msgcat::mcset he DATE_TIME_FORMAT "%d/%m/%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset hi DAYS_OF_WEEK_FULL [list \ "रविवार"\ "सोमवार"\ "मंगलवार"\ "बुधवार"\ "गुरुवार"\ "शुक्रवार"\ "शनिवार"] ::msgcat::mcset hi MONTHS_ABBREV [list \ "जनवरी"\ "फ़रवरी"\ "मार्च"\ "अप्रेल"\ "मई"\ "जून"\ "जुलाई"\ "अगस्त"\ "सितम्बर"\ "अक्टूबर"\ "नवम्बर"\ "दिसम्बर"] ::msgcat::mcset hi MONTHS_FULL [list \ "जनवरी"\ "फ़रवरी"\ "मार्च"\ "अप्रेल"\ "मई"\ "जून"\ "जुलाई"\ "अगस्त"\ "सितम्बर"\ "अक्टूबर"\ "नवम्बर"\ "दिसम्बर"] ::msgcat::mcset hi AM "ईसापूर्व" ::msgcat::mcset hi PM "." |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset hi_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset hi_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset hi_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset hr DAYS_OF_WEEK_ABBREV [list \ "ned"\ "pon"\ "uto"\ "sri"\ "čet"\ "pet"\ "sub"] ::msgcat::mcset hr DAYS_OF_WEEK_FULL [list \ "nedjelja"\ "ponedjeljak"\ "utorak"\ "srijeda"\ "četvrtak"\ "petak"\ "subota"] ::msgcat::mcset hr MONTHS_ABBREV [list \ "sij"\ "vel"\ "ožu"\ "tra"\ "svi"\ "lip"\ "srp"\ "kol"\ "ruj"\ "lis"\ "stu"\ "pro"\ ""] ::msgcat::mcset hr MONTHS_FULL [list \ "siječanj"\ "veljača"\ "ožujak"\ "travanj"\ "svibanj"\ "lipanj"\ "srpanj"\ "kolovoz"\ "rujan"\ "listopad"\ "studeni"\ "prosinac"\ ""] ::msgcat::mcset hr DATE_FORMAT "%Y.%m.%d" ::msgcat::mcset hr TIME_FORMAT "%H:%M:%S" ::msgcat::mcset hr DATE_TIME_FORMAT "%Y.%m.%d %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset hu DAYS_OF_WEEK_ABBREV [list \ "V"\ "H"\ "K"\ "Sze"\ "Cs"\ "P"\ "Szo"] ::msgcat::mcset hu DAYS_OF_WEEK_FULL [list \ "vasárnap"\ "hétfő"\ "kedd"\ "szerda"\ "csütörtök"\ "péntek"\ "szombat"] ::msgcat::mcset hu MONTHS_ABBREV [list \ "jan."\ "febr."\ "márc."\ "ápr."\ "máj."\ "jún."\ "júl."\ "aug."\ "szept."\ "okt."\ "nov."\ "dec."\ ""] ::msgcat::mcset hu MONTHS_FULL [list \ "január"\ "február"\ "március"\ "április"\ "május"\ "június"\ "július"\ "augusztus"\ "szeptember"\ "október"\ "november"\ "december"\ ""] ::msgcat::mcset hu BCE "i.e." ::msgcat::mcset hu CE "i.u." ::msgcat::mcset hu AM "DE" ::msgcat::mcset hu PM "DU" ::msgcat::mcset hu DATE_FORMAT "%Y.%m.%d." ::msgcat::mcset hu TIME_FORMAT "%k:%M:%S" ::msgcat::mcset hu DATE_TIME_FORMAT "%Y.%m.%d. %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset id DAYS_OF_WEEK_ABBREV [list \ "Min"\ "Sen"\ "Sel"\ "Rab"\ "Kam"\ "Jum"\ "Sab"] ::msgcat::mcset id DAYS_OF_WEEK_FULL [list \ "Minggu"\ "Senin"\ "Selasa"\ "Rabu"\ "Kamis"\ "Jumat"\ "Sabtu"] ::msgcat::mcset id MONTHS_ABBREV [list \ "Jan"\ "Peb"\ "Mar"\ "Apr"\ "Mei"\ "Jun"\ "Jul"\ "Agu"\ "Sep"\ "Okt"\ "Nov"\ "Des"\ ""] ::msgcat::mcset id MONTHS_FULL [list \ "Januari"\ "Pebruari"\ "Maret"\ "April"\ "Mei"\ "Juni"\ "Juli"\ "Agustus"\ "September"\ "Oktober"\ "November"\ "Desember"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset id_ID DATE_FORMAT "%d %B %Y" ::msgcat::mcset id_ID TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset id_ID DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset is DAYS_OF_WEEK_ABBREV [list \ "sun."\ "mán."\ "þri."\ "mið."\ "fim."\ "fös."\ "lau."] ::msgcat::mcset is DAYS_OF_WEEK_FULL [list \ "sunnudagur"\ "mánudagur"\ "þriðjudagur"\ "miðvikudagur"\ "fimmtudagur"\ "föstudagur"\ "laugardagur"] ::msgcat::mcset is MONTHS_ABBREV [list \ "jan."\ "feb."\ "mar."\ "apr."\ "maí"\ "jún."\ "júl."\ "ágú."\ "sep."\ "okt."\ "nóv."\ "des."\ ""] ::msgcat::mcset is MONTHS_FULL [list \ "janúar"\ "febrúar"\ "mars"\ "apríl"\ "maí"\ "júní"\ "júlí"\ "ágúst"\ "september"\ "október"\ "nóvember"\ "desember"\ ""] ::msgcat::mcset is DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset is TIME_FORMAT "%H:%M:%S" ::msgcat::mcset is DATE_TIME_FORMAT "%e.%m.%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset it DAYS_OF_WEEK_ABBREV [list \ "dom"\ "lun"\ "mar"\ "mer"\ "gio"\ "ven"\ "sab"] ::msgcat::mcset it DAYS_OF_WEEK_FULL [list \ "domenica"\ "lunedì"\ "martedì"\ "mercoledì"\ "giovedì"\ "venerdì"\ "sabato"] ::msgcat::mcset it MONTHS_ABBREV [list \ "gen"\ "feb"\ "mar"\ "apr"\ "mag"\ "giu"\ "lug"\ "ago"\ "set"\ "ott"\ "nov"\ "dic"\ ""] ::msgcat::mcset it MONTHS_FULL [list \ "gennaio"\ "febbraio"\ "marzo"\ "aprile"\ "maggio"\ "giugno"\ "luglio"\ "agosto"\ "settembre"\ "ottobre"\ "novembre"\ "dicembre"\ ""] ::msgcat::mcset it BCE "aC" ::msgcat::mcset it CE "dC" ::msgcat::mcset it AM "m." ::msgcat::mcset it PM "p." ::msgcat::mcset it DATE_FORMAT "%d %B %Y" ::msgcat::mcset it TIME_FORMAT "%H:%M:%S" ::msgcat::mcset it DATE_TIME_FORMAT "%d %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset it_CH DATE_FORMAT "%e. %B %Y" ::msgcat::mcset it_CH TIME_FORMAT "%H:%M:%S" ::msgcat::mcset it_CH DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 |
# created by tools/loadICU.tcl -- do not edit
::msgcat::mcset ja DAYS_OF_WEEK_ABBREV [list \
"日"\
"月"\
"火"\
"水"\
"木"\
"金"\
"土"]
::msgcat::mcset ja DAYS_OF_WEEK_FULL [list \
"日曜日"\
"月曜日"\
"火曜日"\
"水曜日"\
"木曜日"\
"金曜日"\
"土曜日"]
::msgcat::mcset ja MONTHS_FULL [list \
"1月"\
"2月"\
"3月"\
"4月"\
"5月"\
"6月"\
"7月"\
"8月"\
"9月"\
"10月"\
"11月"\
"12月"]
::msgcat::mcset ja BCE "紀元前"
::msgcat::mcset ja CE "西暦"
::msgcat::mcset ja AM "午前"
::msgcat::mcset ja PM "午後"
::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
|
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kl DAYS_OF_WEEK_ABBREV [list \ "sab"\ "ata"\ "mar"\ "pin"\ "sis"\ "tal"\ "arf"] ::msgcat::mcset kl DAYS_OF_WEEK_FULL [list \ "sabaat"\ "ataasinngorneq"\ "marlunngorneq"\ "pingasunngorneq"\ "sisamanngorneq"\ "tallimanngorneq"\ "arfininngorneq"] ::msgcat::mcset kl MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset kl MONTHS_FULL [list \ "januari"\ "februari"\ "martsi"\ "aprili"\ "maji"\ "juni"\ "juli"\ "augustusi"\ "septemberi"\ "oktoberi"\ "novemberi"\ "decemberi"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kl_GL DATE_FORMAT "%d %b %Y" ::msgcat::mcset kl_GL TIME_FORMAT "%T" ::msgcat::mcset kl_GL TIME_FORMAT_12 "%T" ::msgcat::mcset kl_GL DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ko DAYS_OF_WEEK_ABBREV [list \ "일"\ "월"\ "화"\ "수"\ "목"\ "금"\ "토"] ::msgcat::mcset ko DAYS_OF_WEEK_FULL [list \ "일요일"\ "월요일"\ "화요일"\ "수요일"\ "목요일"\ "금요일"\ "토요일"] ::msgcat::mcset ko MONTHS_ABBREV [list \ "1월"\ "2월"\ "3월"\ "4월"\ "5월"\ "6월"\ "7월"\ "8월"\ "9월"\ "10월"\ "11월"\ "12월"\ ""] ::msgcat::mcset ko MONTHS_FULL [list \ "1월"\ "2월"\ "3월"\ "4월"\ "5월"\ "6월"\ "7월"\ "8월"\ "9월"\ "10월"\ "11월"\ "12월"\ ""] ::msgcat::mcset ko AM "오전" ::msgcat::mcset ko PM "오후" ::msgcat::mcset ko DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset ko TIME_FORMAT_12 "%P %l:%M:%S" ::msgcat::mcset ko DATE_TIME_FORMAT "%Y-%m-%d %P %l:%M:%S %z" ::msgcat::mcset ko LOCALE_DATE_FORMAT "%Y년%B%Od일" ::msgcat::mcset ko LOCALE_TIME_FORMAT "%H시%M분%S초" ::msgcat::mcset ko LOCALE_DATE_TIME_FORMAT "%A %Y년%B%Od일%H시%M분%S초 %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ko_KR BCE "기원전" ::msgcat::mcset ko_KR CE "서기" ::msgcat::mcset ko_KR DATE_FORMAT "%Y.%m.%d" ::msgcat::mcset ko_KR TIME_FORMAT_12 "%P %l:%M:%S" ::msgcat::mcset ko_KR DATE_TIME_FORMAT "%Y.%m.%d %P %l:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kok DAYS_OF_WEEK_FULL [list \ "आदित्यवार"\ "सोमवार"\ "मंगळार"\ "बुधवार"\ "गुरुवार"\ "शुक्रवार"\ "शनिवार"] ::msgcat::mcset kok MONTHS_ABBREV [list \ "जानेवारी"\ "फेबृवारी"\ "मार्च"\ "एप्रिल"\ "मे"\ "जून"\ "जुलै"\ "ओगस्ट"\ "सेप्टेंबर"\ "ओक्टोबर"\ "नोव्हेंबर"\ "डिसेंबर"] ::msgcat::mcset kok MONTHS_FULL [list \ "जानेवारी"\ "फेब्रुवारी"\ "मार्च"\ "एप्रिल"\ "मे"\ "जून"\ "जुलै"\ "ओगस्ट"\ "सेप्टेंबर"\ "ओक्टोबर"\ "नोव्हेंबर"\ "डिसेंबर"] ::msgcat::mcset kok AM "क्रिस्तपूर्व" ::msgcat::mcset kok PM "क्रिस्तशखा" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kok_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset kok_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset kok_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kw DAYS_OF_WEEK_ABBREV [list \ "Sul"\ "Lun"\ "Mth"\ "Mhr"\ "Yow"\ "Gwe"\ "Sad"] ::msgcat::mcset kw DAYS_OF_WEEK_FULL [list \ "De Sul"\ "De Lun"\ "De Merth"\ "De Merher"\ "De Yow"\ "De Gwener"\ "De Sadorn"] ::msgcat::mcset kw MONTHS_ABBREV [list \ "Gen"\ "Whe"\ "Mer"\ "Ebr"\ "Me"\ "Evn"\ "Gor"\ "Est"\ "Gwn"\ "Hed"\ "Du"\ "Kev"\ ""] ::msgcat::mcset kw MONTHS_FULL [list \ "Mys Genver"\ "Mys Whevrel"\ "Mys Merth"\ "Mys Ebrel"\ "Mys Me"\ "Mys Evan"\ "Mys Gortheren"\ "Mye Est"\ "Mys Gwyngala"\ "Mys Hedra"\ "Mys Du"\ "Mys Kevardhu"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset kw_GB DATE_FORMAT "%d %B %Y" ::msgcat::mcset kw_GB TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset kw_GB DATE_TIME_FORMAT "%d %B %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset lt DAYS_OF_WEEK_ABBREV [list \ "Sk"\ "Pr"\ "An"\ "Tr"\ "Kt"\ "Pn"\ "Št"] ::msgcat::mcset lt DAYS_OF_WEEK_FULL [list \ "Sekmadienis"\ "Pirmadienis"\ "Antradienis"\ "Trečiadienis"\ "Ketvirtadienis"\ "Penktadienis"\ "Šeštadienis"] ::msgcat::mcset lt MONTHS_ABBREV [list \ "Sau"\ "Vas"\ "Kov"\ "Bal"\ "Geg"\ "Bir"\ "Lie"\ "Rgp"\ "Rgs"\ "Spa"\ "Lap"\ "Grd"\ ""] ::msgcat::mcset lt MONTHS_FULL [list \ "Sausio"\ "Vasario"\ "Kovo"\ "Balandžio"\ "Gegužės"\ "Birželio"\ "Liepos"\ "Rugpjūčio"\ "Rugsėjo"\ "Spalio"\ "Lapkričio"\ "Gruodžio"\ ""] ::msgcat::mcset lt BCE "pr.Kr." ::msgcat::mcset lt CE "po.Kr." ::msgcat::mcset lt DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset lt TIME_FORMAT "%H.%M.%S" ::msgcat::mcset lt DATE_TIME_FORMAT "%Y.%m.%e %H.%M.%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset lv DAYS_OF_WEEK_ABBREV [list \ "Sv"\ "P"\ "O"\ "T"\ "C"\ "Pk"\ "S"] ::msgcat::mcset lv DAYS_OF_WEEK_FULL [list \ "svētdiena"\ "pirmdiena"\ "otrdiena"\ "trešdiena"\ "ceturdien"\ "piektdiena"\ "sestdiena"] ::msgcat::mcset lv MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mar"\ "Apr"\ "Maijs"\ "Jūn"\ "Jūl"\ "Aug"\ "Sep"\ "Okt"\ "Nov"\ "Dec"\ ""] ::msgcat::mcset lv MONTHS_FULL [list \ "janvāris"\ "februāris"\ "marts"\ "aprīlis"\ "maijs"\ "jūnijs"\ "jūlijs"\ "augusts"\ "septembris"\ "oktobris"\ "novembris"\ "decembris"\ ""] ::msgcat::mcset lv BCE "pmē" ::msgcat::mcset lv CE "mē" ::msgcat::mcset lv DATE_FORMAT "%Y.%e.%m" ::msgcat::mcset lv TIME_FORMAT "%H:%M:%S" ::msgcat::mcset lv DATE_TIME_FORMAT "%Y.%e.%m %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset mk DAYS_OF_WEEK_ABBREV [list \ "нед."\ "пон."\ "вт."\ "сре."\ "чет."\ "пет."\ "саб."] ::msgcat::mcset mk DAYS_OF_WEEK_FULL [list \ "недела"\ "понеделник"\ "вторник"\ "среда"\ "четврток"\ "петок"\ "сабота"] ::msgcat::mcset mk MONTHS_ABBREV [list \ "јан."\ "фев."\ "мар."\ "апр."\ "мај."\ "јун."\ "јул."\ "авг."\ "септ."\ "окт."\ "ноем."\ "декем."\ ""] ::msgcat::mcset mk MONTHS_FULL [list \ "јануари"\ "февруари"\ "март"\ "април"\ "мај"\ "јуни"\ "јули"\ "август"\ "септември"\ "октомври"\ "ноември"\ "декември"\ ""] ::msgcat::mcset mk BCE "пр.н.е." ::msgcat::mcset mk CE "ае." ::msgcat::mcset mk DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset mk TIME_FORMAT "%H:%M:%S %z" ::msgcat::mcset mk DATE_TIME_FORMAT "%e.%m.%Y %H:%M:%S %z %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset mr DAYS_OF_WEEK_FULL [list \ "रविवार"\ "सोमवार"\ "मंगळवार"\ "मंगळवार"\ "गुरुवार"\ "शुक्रवार"\ "शनिवार"] ::msgcat::mcset mr MONTHS_ABBREV [list \ "जानेवारी"\ "फेबृवारी"\ "मार्च"\ "एप्रिल"\ "मे"\ "जून"\ "जुलै"\ "ओगस्ट"\ "सेप्टेंबर"\ "ओक्टोबर"\ "नोव्हेंबर"\ "डिसेंबर"] ::msgcat::mcset mr MONTHS_FULL [list \ "जानेवारी"\ "फेबृवारी"\ "मार्च"\ "एप्रिल"\ "मे"\ "जून"\ "जुलै"\ "ओगस्ट"\ "सेप्टेंबर"\ "ओक्टोबर"\ "नोव्हेंबर"\ "डिसेंबर"] ::msgcat::mcset mr AM "BC" ::msgcat::mcset mr PM "AD" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset mr_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset mr_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset mr_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ms DAYS_OF_WEEK_ABBREV [list \ "Aha"\ "Isn"\ "Sei"\ "Rab"\ "Kha"\ "Jum"\ "Sab"] ::msgcat::mcset ms DAYS_OF_WEEK_FULL [list \ "Ahad"\ "Isnin"\ "Selasa"\ "Rahu"\ "Khamis"\ "Jumaat"\ "Sabtu"] ::msgcat::mcset ms MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mac"\ "Apr"\ "Mei"\ "Jun"\ "Jul"\ "Ogos"\ "Sep"\ "Okt"\ "Nov"\ "Dis"\ ""] ::msgcat::mcset ms MONTHS_FULL [list \ "Januari"\ "Februari"\ "Mac"\ "April"\ "Mei"\ "Jun"\ "Julai"\ "Ogos"\ "September"\ "Oktober"\ "November"\ "Disember"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ms_MY DATE_FORMAT "%A %d %b %Y" ::msgcat::mcset ms_MY TIME_FORMAT_12 "%I:%M:%S %z" ::msgcat::mcset ms_MY DATE_TIME_FORMAT "%A %d %b %Y %I:%M:%S %z %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset mt DAYS_OF_WEEK_ABBREV [list \ "Ħad"\ "Tne"\ "Tli"\ "Erb"\ "Ħam"\ "Ġim"] ::msgcat::mcset mt MONTHS_ABBREV [list \ "Jan"\ "Fra"\ "Mar"\ "Apr"\ "Mej"\ "Ġun"\ "Lul"\ "Awi"\ "Set"\ "Ott"\ "Nov"] ::msgcat::mcset mt BCE "QK" ::msgcat::mcset mt CE "" ::msgcat::mcset mt DATE_FORMAT "%A, %e ta %B, %Y" ::msgcat::mcset mt TIME_FORMAT_12 "%l:%M:%S %P" ::msgcat::mcset mt DATE_TIME_FORMAT "%A, %e ta %B, %Y %l:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset nb DAYS_OF_WEEK_ABBREV [list \ "sø"\ "ma"\ "ti"\ "on"\ "to"\ "fr"\ "lø"] ::msgcat::mcset nb DAYS_OF_WEEK_FULL [list \ "søndag"\ "mandag"\ "tirsdag"\ "onsdag"\ "torsdag"\ "fredag"\ "lørdag"] ::msgcat::mcset nb MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "mai"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "des"\ ""] ::msgcat::mcset nb MONTHS_FULL [list \ "januar"\ "februar"\ "mars"\ "april"\ "mai"\ "juni"\ "juli"\ "august"\ "september"\ "oktober"\ "november"\ "desember"\ ""] ::msgcat::mcset nb BCE "f.Kr." ::msgcat::mcset nb CE "e.Kr." ::msgcat::mcset nb DATE_FORMAT "%e. %B %Y" ::msgcat::mcset nb TIME_FORMAT "%H:%M:%S" ::msgcat::mcset nb DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset nl DAYS_OF_WEEK_ABBREV [list \ "zo"\ "ma"\ "di"\ "wo"\ "do"\ "vr"\ "za"] ::msgcat::mcset nl DAYS_OF_WEEK_FULL [list \ "zondag"\ "maandag"\ "dinsdag"\ "woensdag"\ "donderdag"\ "vrijdag"\ "zaterdag"] ::msgcat::mcset nl MONTHS_ABBREV [list \ "jan"\ "feb"\ "mrt"\ "apr"\ "mei"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset nl MONTHS_FULL [list \ "januari"\ "februari"\ "maart"\ "april"\ "mei"\ "juni"\ "juli"\ "augustus"\ "september"\ "oktober"\ "november"\ "december"\ ""] ::msgcat::mcset nl DATE_FORMAT "%e %B %Y" ::msgcat::mcset nl TIME_FORMAT "%k:%M:%S" ::msgcat::mcset nl DATE_TIME_FORMAT "%e %B %Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset nl_BE DATE_FORMAT "%d-%m-%y" ::msgcat::mcset nl_BE TIME_FORMAT "%T" ::msgcat::mcset nl_BE TIME_FORMAT_12 "%T" ::msgcat::mcset nl_BE DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset nn DAYS_OF_WEEK_ABBREV [list \ "su"\ "må"\ "ty"\ "on"\ "to"\ "fr"\ "lau"] ::msgcat::mcset nn DAYS_OF_WEEK_FULL [list \ "sundag"\ "måndag"\ "tysdag"\ "onsdag"\ "torsdag"\ "fredag"\ "laurdag"] ::msgcat::mcset nn MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "mai"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "des"\ ""] ::msgcat::mcset nn MONTHS_FULL [list \ "januar"\ "februar"\ "mars"\ "april"\ "mai"\ "juni"\ "juli"\ "august"\ "september"\ "oktober"\ "november"\ "desember"\ ""] ::msgcat::mcset nn BCE "f.Kr." ::msgcat::mcset nn CE "e.Kr." ::msgcat::mcset nn DATE_FORMAT "%e. %B %Y" ::msgcat::mcset nn TIME_FORMAT "%H:%M:%S" ::msgcat::mcset nn DATE_TIME_FORMAT "%e. %B %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset pl DAYS_OF_WEEK_ABBREV [list \ "N"\ "Pn"\ "Wt"\ "Śr"\ "Cz"\ "Pt"\ "So"] ::msgcat::mcset pl DAYS_OF_WEEK_FULL [list \ "niedziela"\ "poniedziałek"\ "wtorek"\ "środa"\ "czwartek"\ "piątek"\ "sobota"] ::msgcat::mcset pl MONTHS_ABBREV [list \ "sty"\ "lut"\ "mar"\ "kwi"\ "maj"\ "cze"\ "lip"\ "sie"\ "wrz"\ "paź"\ "lis"\ "gru"\ ""] ::msgcat::mcset pl MONTHS_FULL [list \ "styczeń"\ "luty"\ "marzec"\ "kwiecień"\ "maj"\ "czerwiec"\ "lipiec"\ "sierpień"\ "wrzesień"\ "październik"\ "listopad"\ "grudzień"\ ""] ::msgcat::mcset pl BCE "p.n.e." ::msgcat::mcset pl CE "n.e." ::msgcat::mcset pl DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset pl TIME_FORMAT "%H:%M:%S" ::msgcat::mcset pl DATE_TIME_FORMAT "%Y-%m-%d %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset pt DAYS_OF_WEEK_ABBREV [list \ "Dom"\ "Seg"\ "Ter"\ "Qua"\ "Qui"\ "Sex"\ "Sáb"] ::msgcat::mcset pt DAYS_OF_WEEK_FULL [list \ "Domingo"\ "Segunda-feira"\ "Terça-feira"\ "Quarta-feira"\ "Quinta-feira"\ "Sexta-feira"\ "Sábado"] ::msgcat::mcset pt MONTHS_ABBREV [list \ "Jan"\ "Fev"\ "Mar"\ "Abr"\ "Mai"\ "Jun"\ "Jul"\ "Ago"\ "Set"\ "Out"\ "Nov"\ "Dez"\ ""] ::msgcat::mcset pt MONTHS_FULL [list \ "Janeiro"\ "Fevereiro"\ "Março"\ "Abril"\ "Maio"\ "Junho"\ "Julho"\ "Agosto"\ "Setembro"\ "Outubro"\ "Novembro"\ "Dezembro"\ ""] ::msgcat::mcset pt DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset pt TIME_FORMAT "%k:%M:%S" ::msgcat::mcset pt DATE_TIME_FORMAT "%d-%m-%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset pt_BR DATE_FORMAT "%d-%m-%Y" ::msgcat::mcset pt_BR TIME_FORMAT "%T" ::msgcat::mcset pt_BR TIME_FORMAT_12 "%T" ::msgcat::mcset pt_BR DATE_TIME_FORMAT "%a %d %b %Y %T %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ro DAYS_OF_WEEK_ABBREV [list \ "D"\ "L"\ "Ma"\ "Mi"\ "J"\ "V"\ "S"] ::msgcat::mcset ro DAYS_OF_WEEK_FULL [list \ "duminică"\ "luni"\ "marţi"\ "miercuri"\ "joi"\ "vineri"\ "sîmbătă"] ::msgcat::mcset ro MONTHS_ABBREV [list \ "Ian"\ "Feb"\ "Mar"\ "Apr"\ "Mai"\ "Iun"\ "Iul"\ "Aug"\ "Sep"\ "Oct"\ "Nov"\ "Dec"\ ""] ::msgcat::mcset ro MONTHS_FULL [list \ "ianuarie"\ "februarie"\ "martie"\ "aprilie"\ "mai"\ "iunie"\ "iulie"\ "august"\ "septembrie"\ "octombrie"\ "noiembrie"\ "decembrie"\ ""] ::msgcat::mcset ro BCE "d.C." ::msgcat::mcset ro CE "î.d.C." ::msgcat::mcset ro DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ro TIME_FORMAT "%H:%M:%S" ::msgcat::mcset ro DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ru DAYS_OF_WEEK_ABBREV [list \ "Вс"\ "Пн"\ "Вт"\ "Ср"\ "Чт"\ "Пт"\ "Сб"] ::msgcat::mcset ru DAYS_OF_WEEK_FULL [list \ "воскресенье"\ "понедельник"\ "вторник"\ "среда"\ "четверг"\ "пятница"\ "суббота"] ::msgcat::mcset ru MONTHS_ABBREV [list \ "янв"\ "фев"\ "мар"\ "апр"\ "май"\ "июн"\ "июл"\ "авг"\ "сен"\ "окт"\ "ноя"\ "дек"\ ""] ::msgcat::mcset ru MONTHS_FULL [list \ "Январь"\ "Февраль"\ "Март"\ "Апрель"\ "Май"\ "Июнь"\ "Июль"\ "Август"\ "Сентябрь"\ "Октябрь"\ "Ноябрь"\ "Декабрь"\ ""] ::msgcat::mcset ru BCE "до н.э." ::msgcat::mcset ru CE "н.э." ::msgcat::mcset ru DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ru TIME_FORMAT "%k:%M:%S" ::msgcat::mcset ru DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ru_UA DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset ru_UA TIME_FORMAT "%k:%M:%S" ::msgcat::mcset ru_UA DATE_TIME_FORMAT "%d.%m.%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sh DAYS_OF_WEEK_ABBREV [list \ "Ned"\ "Pon"\ "Uto"\ "Sre"\ "Čet"\ "Pet"\ "Sub"] ::msgcat::mcset sh DAYS_OF_WEEK_FULL [list \ "Nedelja"\ "Ponedeljak"\ "Utorak"\ "Sreda"\ "Četvrtak"\ "Petak"\ "Subota"] ::msgcat::mcset sh MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mar"\ "Apr"\ "Maj"\ "Jun"\ "Jul"\ "Avg"\ "Sep"\ "Okt"\ "Nov"\ "Dec"\ ""] ::msgcat::mcset sh MONTHS_FULL [list \ "Januar"\ "Februar"\ "Mart"\ "April"\ "Maj"\ "Juni"\ "Juli"\ "Avgust"\ "Septembar"\ "Oktobar"\ "Novembar"\ "Decembar"\ ""] ::msgcat::mcset sh BCE "p. n. e." ::msgcat::mcset sh CE "n. e." ::msgcat::mcset sh DATE_FORMAT "%d.%m.%Y." ::msgcat::mcset sh TIME_FORMAT "%k.%M.%S" ::msgcat::mcset sh DATE_TIME_FORMAT "%d.%m.%Y. %k.%M.%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sk DAYS_OF_WEEK_ABBREV [list \ "Ne"\ "Po"\ "Ut"\ "St"\ "Št"\ "Pa"\ "So"] ::msgcat::mcset sk DAYS_OF_WEEK_FULL [list \ "Nedeľe"\ "Pondelok"\ "Utorok"\ "Streda"\ "Štvrtok"\ "Piatok"\ "Sobota"] ::msgcat::mcset sk MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "máj"\ "jún"\ "júl"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset sk MONTHS_FULL [list \ "január"\ "február"\ "marec"\ "apríl"\ "máj"\ "jún"\ "júl"\ "august"\ "september"\ "október"\ "november"\ "december"\ ""] ::msgcat::mcset sk BCE "pred n.l." ::msgcat::mcset sk CE "n.l." ::msgcat::mcset sk DATE_FORMAT "%e.%m.%Y" ::msgcat::mcset sk TIME_FORMAT "%k:%M:%S" ::msgcat::mcset sk DATE_TIME_FORMAT "%e.%m.%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sl DAYS_OF_WEEK_ABBREV [list \ "Ned"\ "Pon"\ "Tor"\ "Sre"\ "Čet"\ "Pet"\ "Sob"] ::msgcat::mcset sl DAYS_OF_WEEK_FULL [list \ "Nedelja"\ "Ponedeljek"\ "Torek"\ "Sreda"\ "Četrtek"\ "Petek"\ "Sobota"] ::msgcat::mcset sl MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ "avg"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset sl MONTHS_FULL [list \ "januar"\ "februar"\ "marec"\ "april"\ "maj"\ "junij"\ "julij"\ "avgust"\ "september"\ "oktober"\ "november"\ "december"\ ""] ::msgcat::mcset sl BCE "pr.n.š." ::msgcat::mcset sl CE "po Kr." ::msgcat::mcset sl DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset sl TIME_FORMAT "%k:%M:%S" ::msgcat::mcset sl DATE_TIME_FORMAT "%Y.%m.%e %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sq DAYS_OF_WEEK_ABBREV [list \ "Die"\ "Hën"\ "Mar"\ "Mër"\ "Enj"\ "Pre"\ "Sht"] ::msgcat::mcset sq DAYS_OF_WEEK_FULL [list \ "e diel"\ "e hënë"\ "e martë"\ "e mërkurë"\ "e enjte"\ "e premte"\ "e shtunë"] ::msgcat::mcset sq MONTHS_ABBREV [list \ "Jan"\ "Shk"\ "Mar"\ "Pri"\ "Maj"\ "Qer"\ "Kor"\ "Gsh"\ "Sht"\ "Tet"\ "Nën"\ "Dhj"\ ""] ::msgcat::mcset sq MONTHS_FULL [list \ "janar"\ "shkurt"\ "mars"\ "prill"\ "maj"\ "qershor"\ "korrik"\ "gusht"\ "shtator"\ "tetor"\ "nëntor"\ "dhjetor"\ ""] ::msgcat::mcset sq BCE "p.e.r." ::msgcat::mcset sq CE "n.e.r." ::msgcat::mcset sq AM "PD" ::msgcat::mcset sq PM "MD" ::msgcat::mcset sq DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset sq TIME_FORMAT_12 "%l:%M:%S.%P" ::msgcat::mcset sq DATE_TIME_FORMAT "%Y-%m-%d %l:%M:%S.%P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sr DAYS_OF_WEEK_ABBREV [list \ "Нед"\ "Пон"\ "Уто"\ "Сре"\ "Чет"\ "Пет"\ "Суб"] ::msgcat::mcset sr DAYS_OF_WEEK_FULL [list \ "Недеља"\ "Понедељак"\ "Уторак"\ "Среда"\ "Четвртак"\ "Петак"\ "Субота"] ::msgcat::mcset sr MONTHS_ABBREV [list \ "Јан"\ "Феб"\ "Мар"\ "Апр"\ "Мај"\ "Јун"\ "Јул"\ "Авг"\ "Сеп"\ "Окт"\ "Нов"\ "Дец"\ ""] ::msgcat::mcset sr MONTHS_FULL [list \ "Јануар"\ "Фебруар"\ "Март"\ "Април"\ "Мај"\ "Јуни"\ "Јули"\ "Август"\ "Септембар"\ "Октобар"\ "Новембар"\ "Децембар"\ ""] ::msgcat::mcset sr BCE "п. н. е." ::msgcat::mcset sr CE "н. е" ::msgcat::mcset sr DATE_FORMAT "%Y.%m.%e" ::msgcat::mcset sr TIME_FORMAT "%k.%M.%S" ::msgcat::mcset sr DATE_TIME_FORMAT "%Y.%m.%e %k.%M.%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sv DAYS_OF_WEEK_ABBREV [list \ "sö"\ "må"\ "ti"\ "on"\ "to"\ "fr"\ "lö"] ::msgcat::mcset sv DAYS_OF_WEEK_FULL [list \ "söndag"\ "måndag"\ "tisdag"\ "onsdag"\ "torsdag"\ "fredag"\ "lördag"] ::msgcat::mcset sv MONTHS_ABBREV [list \ "jan"\ "feb"\ "mar"\ "apr"\ "maj"\ "jun"\ "jul"\ "aug"\ "sep"\ "okt"\ "nov"\ "dec"\ ""] ::msgcat::mcset sv MONTHS_FULL [list \ "januari"\ "februari"\ "mars"\ "april"\ "maj"\ "juni"\ "juli"\ "augusti"\ "september"\ "oktober"\ "november"\ "december"\ ""] ::msgcat::mcset sv BCE "f.Kr." ::msgcat::mcset sv CE "e.Kr." ::msgcat::mcset sv DATE_FORMAT "%Y-%m-%d" ::msgcat::mcset sv TIME_FORMAT "%H:%M:%S" ::msgcat::mcset sv DATE_TIME_FORMAT "%Y-%m-%d %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset sw DAYS_OF_WEEK_ABBREV [list \ "Jpi"\ "Jtt"\ "Jnn"\ "Jtn"\ "Alh"\ "Iju"\ "Jmo"] ::msgcat::mcset sw DAYS_OF_WEEK_FULL [list \ "Jumapili"\ "Jumatatu"\ "Jumanne"\ "Jumatano"\ "Alhamisi"\ "Ijumaa"\ "Jumamosi"] ::msgcat::mcset sw MONTHS_ABBREV [list \ "Jan"\ "Feb"\ "Mar"\ "Apr"\ "Mei"\ "Jun"\ "Jul"\ "Ago"\ "Sep"\ "Okt"\ "Nov"\ "Des"\ ""] ::msgcat::mcset sw MONTHS_FULL [list \ "Januari"\ "Februari"\ "Machi"\ "Aprili"\ "Mei"\ "Juni"\ "Julai"\ "Agosti"\ "Septemba"\ "Oktoba"\ "Novemba"\ "Desemba"\ ""] ::msgcat::mcset sw BCE "KK" ::msgcat::mcset sw CE "BK" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ta DAYS_OF_WEEK_FULL [list \ "ஞாயிறு"\ "திங்கள்"\ "செவ்வாய்"\ "புதன்"\ "வியாழன்"\ "வெள்ளி"\ "சனி"] ::msgcat::mcset ta MONTHS_ABBREV [list \ "ஜனவரி"\ "பெப்ரவரி"\ "மார்ச்"\ "ஏப்ரல்"\ "மே"\ "ஜூன்"\ "ஜூலை"\ "ஆகஸ்ட்"\ "செப்டம்பர்"\ "அக்டோபர்"\ "நவம்பர்"\ "டிசம்பர்r"] ::msgcat::mcset ta MONTHS_FULL [list \ "ஜனவரி"\ "பெப்ரவரி"\ "மார்ச்"\ "ஏப்ரல்"\ "மே"\ "ஜூன்"\ "ஜூலை"\ "ஆகஸ்ட்"\ "செப்டம்பர்"\ "அக்டோபர்"\ "நவம்பர்"\ "டிசம்பர்r"] ::msgcat::mcset ta AM "கிமு" ::msgcat::mcset ta PM "கிபி" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | < | 1 2 3 4 5 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset ta_IN DATE_FORMAT "%d %M %Y" ::msgcat::mcset ta_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset ta_IN DATE_TIME_FORMAT "%d %M %Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset te DAYS_OF_WEEK_ABBREV [list \ "ఆది"\ "సోమ"\ "మంగళ"\ "బుధ"\ "గురు"\ "శుక్ర"\ "శని"] ::msgcat::mcset te DAYS_OF_WEEK_FULL [list \ "ఆదివారం"\ "సోమవారం"\ "మంగళవారం"\ "బుధవారం"\ "గురువారం"\ "శుక్రవారం"\ "శనివారం"] ::msgcat::mcset te MONTHS_ABBREV [list \ "జనవరి"\ "ఫిబ్రవరి"\ "మార్చి"\ "ఏప్రిల్"\ "మే"\ "జూన్"\ "జూలై"\ "ఆగస్టు"\ "సెప్టెంబర్"\ "అక్టోబర్"\ "నవంబర్"\ "డిసెంబర్"\ ""] ::msgcat::mcset te MONTHS_FULL [list \ "జనవరి"\ "ఫిబ్రవరి"\ "మార్చి"\ "ఏప్రిల్"\ "మే"\ "జూన్"\ "జూలై"\ "ఆగస్టు"\ "సెప్టెంబర్"\ "అక్టోబర్"\ "నవంబర్"\ "డిసెంబర్"\ ""] |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset te_IN AM "పూర్వాహ్న" ::msgcat::mcset te_IN PM "అపరాహ్న" ::msgcat::mcset te_IN DATE_FORMAT "%d/%m/%Y" ::msgcat::mcset te_IN TIME_FORMAT_12 "%I:%M:%S %P" ::msgcat::mcset te_IN DATE_TIME_FORMAT "%d/%m/%Y %I:%M:%S %P %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset th DAYS_OF_WEEK_ABBREV [list \ "อา."\ "จ."\ "อ."\ "พ."\ "พฤ."\ "ศ."\ "ส."] ::msgcat::mcset th DAYS_OF_WEEK_FULL [list \ "วันอาทิตย์"\ "วันจันทร์"\ "วันอังคาร"\ "วันพุธ"\ "วันพฤหัสบดี"\ "วันศุกร์"\ "วันเสาร์"] ::msgcat::mcset th MONTHS_ABBREV [list \ "ม.ค."\ "ก.พ."\ "มี.ค."\ "เม.ย."\ "พ.ค."\ "มิ.ย."\ "ก.ค."\ "ส.ค."\ "ก.ย."\ "ต.ค."\ "พ.ย."\ "ธ.ค."\ ""] ::msgcat::mcset th MONTHS_FULL [list \ "มกราคม"\ "กุมภาพันธ์"\ "มีนาคม"\ "เมษายน"\ "พฤษภาคม"\ "มิถุนายน"\ "กรกฎาคม"\ "สิงหาคม"\ "กันยายน"\ "ตุลาคม"\ "พฤศจิกายน"\ "ธันวาคม"\ ""] ::msgcat::mcset th BCE "ลที่" ::msgcat::mcset th CE "ค.ศ." ::msgcat::mcset th AM "ก่อนเที่ยง" ::msgcat::mcset th PM "หลังเที่ยง" ::msgcat::mcset th DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset th TIME_FORMAT "%k:%M:%S" ::msgcat::mcset th DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset tr DAYS_OF_WEEK_ABBREV [list \ "Paz"\ "Pzt"\ "Sal"\ "Çar"\ "Per"\ "Cum"\ "Cmt"] ::msgcat::mcset tr DAYS_OF_WEEK_FULL [list \ "Pazar"\ "Pazartesi"\ "Salı"\ "Çarşamba"\ "Perşembe"\ "Cuma"\ "Cumartesi"] ::msgcat::mcset tr MONTHS_ABBREV [list \ "Oca"\ "Şub"\ "Mar"\ "Nis"\ "May"\ "Haz"\ "Tem"\ "Ağu"\ "Eyl"\ "Eki"\ "Kas"\ "Ara"\ ""] ::msgcat::mcset tr MONTHS_FULL [list \ "Ocak"\ "Şubat"\ "Mart"\ "Nisan"\ "Mayıs"\ "Haziran"\ "Temmuz"\ "Ağustos"\ "Eylül"\ "Ekim"\ "Kasım"\ "Aralık"\ ""] ::msgcat::mcset tr DATE_FORMAT "%d.%m.%Y" ::msgcat::mcset tr TIME_FORMAT "%H:%M:%S" ::msgcat::mcset tr DATE_TIME_FORMAT "%d.%m.%Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset uk DAYS_OF_WEEK_ABBREV [list \ "нд"\ "пн"\ "вт"\ "ср"\ "чт"\ "пт"\ "сб"] ::msgcat::mcset uk DAYS_OF_WEEK_FULL [list \ "неділя"\ "понеділок"\ "вівторок"\ "середа"\ "четвер"\ "п'ятниця"\ "субота"] ::msgcat::mcset uk MONTHS_ABBREV [list \ "січ"\ "лют"\ "бер"\ "квіт"\ "трав"\ "черв"\ "лип"\ "серп"\ "вер"\ "жовт"\ "лист"\ "груд"\ ""] ::msgcat::mcset uk MONTHS_FULL [list \ "січня"\ "лютого"\ "березня"\ "квітня"\ "травня"\ "червня"\ "липня"\ "серпня"\ "вересня"\ "жовтня"\ "листопада"\ "грудня"\ ""] ::msgcat::mcset uk BCE "до н.е." ::msgcat::mcset uk CE "після н.е." ::msgcat::mcset uk DATE_FORMAT "%e/%m/%Y" ::msgcat::mcset uk TIME_FORMAT "%k:%M:%S" ::msgcat::mcset uk DATE_TIME_FORMAT "%e/%m/%Y %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset vi DAYS_OF_WEEK_ABBREV [list \ "Th 2"\ "Th 3"\ "Th 4"\ "Th 5"\ "Th 6"\ "Th 7"\ "CN"] ::msgcat::mcset vi DAYS_OF_WEEK_FULL [list \ "Thứ hai"\ "Thứ ba"\ "Thứ tư"\ "Thứ năm"\ "Thứ sáu"\ "Thứ bảy"\ "Chủ nhật"] ::msgcat::mcset vi MONTHS_ABBREV [list \ "Thg 1"\ "Thg 2"\ "Thg 3"\ "Thg 4"\ "Thg 5"\ "Thg 6"\ "Thg 7"\ "Thg 8"\ "Thg 9"\ "Thg 10"\ "Thg 11"\ "Thg 12"\ ""] ::msgcat::mcset vi MONTHS_FULL [list \ "Tháng một"\ "Tháng hai"\ "Tháng ba"\ "Tháng tư"\ "Tháng năm"\ "Tháng sáu"\ "Tháng bảy"\ "Tháng tám"\ "Tháng chín"\ "Tháng mười"\ "Tháng mười một"\ "Tháng mười hai"\ ""] ::msgcat::mcset vi DATE_FORMAT "%d %b %Y" ::msgcat::mcset vi TIME_FORMAT "%H:%M:%S" ::msgcat::mcset vi DATE_TIME_FORMAT "%d %b %Y %H:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset zh DAYS_OF_WEEK_ABBREV [list \ "星期日"\ "星期一"\ "星期二"\ "星期三"\ "星期四"\ "星期五"\ "星期六"] ::msgcat::mcset zh DAYS_OF_WEEK_FULL [list \ "星期日"\ "星期一"\ "星期二"\ "星期三"\ "星期四"\ "星期五"\ "星期六"] ::msgcat::mcset zh MONTHS_ABBREV [list \ "一月"\ "二月"\ "三月"\ "四月"\ "五月"\ "六月"\ "七月"\ "八月"\ "九月"\ "十月"\ "十一月"\ "十二月"\ ""] ::msgcat::mcset zh MONTHS_FULL [list \ "一月"\ "二月"\ "三月"\ "四月"\ "五月"\ "六月"\ "七月"\ "八月"\ "九月"\ "十月"\ "十一月"\ "十二月"\ ""] ::msgcat::mcset zh BCE "公元前" ::msgcat::mcset zh CE "公元" ::msgcat::mcset zh AM "上午" ::msgcat::mcset zh PM "下午" ::msgcat::mcset zh LOCALE_NUMERALS "〇 一 二 三 四 五 六 七 八 九 十 十一 十二 十三 十四 十五 十六 十七 十八 十九 二十 廿一 廿二 廿三 廿四 廿五 廿六 廿七 廿八 廿九 三十 卅一 卅二 卅三 卅四 卅五 卅六 卅七 卅八 卅九 四十 四十一 四十二 四十三 四十四 四十五 四十六 四十七 四十八 四十九 五十 五十一 五十二 五十三 五十四 五十五 五十六 五十七 五十八 五十九 六十 六十一 六十二 六十三 六十四 六十五 六十六 六十七 六十八 六十九 七十 七十一 七十二 七十三 七十四 七十五 七十六 七十七 七十八 七十九 八十 八十一 八十二 八十三 八十四 八十五 八十六 八十七 八十八 八十九 九十 九十一 九十二 九十三 九十四 九十五 九十六 九十七 九十八 九十九" ::msgcat::mcset zh LOCALE_DATE_FORMAT "公元%Y年%B%Od日" ::msgcat::mcset zh LOCALE_TIME_FORMAT "%OH时%OM分%OS秒" ::msgcat::mcset zh LOCALE_DATE_TIME_FORMAT "%A %Y年%B%Od日%OH时%OM分%OS秒 %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | < | 1 2 3 4 5 6 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset zh_CN DATE_FORMAT "%Y-%m-%e" ::msgcat::mcset zh_CN TIME_FORMAT "%k:%M:%S" ::msgcat::mcset zh_CN TIME_FORMAT_12 "%P%I时%M分%S秒" ::msgcat::mcset zh_CN DATE_TIME_FORMAT "%Y-%m-%e %k:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 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 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset zh_HK DAYS_OF_WEEK_ABBREV [list \ "日"\ "一"\ "二"\ "三"\ "四"\ "五"\ "六"] ::msgcat::mcset zh_HK MONTHS_ABBREV [list \ "1月"\ "2月"\ "3月"\ "4月"\ "5月"\ "6月"\ "7月"\ "8月"\ "9月"\ "10月"\ "11月"\ "12月"\ ""] ::msgcat::mcset zh_HK DATE_FORMAT "%Y年%m月%e日" ::msgcat::mcset zh_HK TIME_FORMAT_12 "%P%I:%M:%S" ::msgcat::mcset zh_HK DATE_TIME_FORMAT "%Y年%m月%e日 %P%I:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset zh_SG AM "上午" ::msgcat::mcset zh_SG PM "中午" ::msgcat::mcset zh_SG DATE_FORMAT "%d %B %Y" ::msgcat::mcset zh_SG TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_SG DATE_TIME_FORMAT "%d %B %Y %P %I:%M:%S %z" |
1 | # created by tools/loadICU.tcl -- do not edit | | | | | | | < | 1 2 3 4 5 6 7 | # created by tools/loadICU.tcl -- do not edit ::msgcat::mcset zh_TW BCE "民國前" ::msgcat::mcset zh_TW CE "民國" ::msgcat::mcset zh_TW DATE_FORMAT "%Y/%m/%e" ::msgcat::mcset zh_TW TIME_FORMAT_12 "%P %I:%M:%S" ::msgcat::mcset zh_TW DATE_TIME_FORMAT "%Y/%m/%e %P %I:%M:%S %z" |
1 2 3 4 5 6 7 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely |
| ︙ | ︙ |
1 2 3 4 5 6 7 | # 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 | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # 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 |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval tcl::Pkg {}
# ::tcl::Pkg::CompareExtension --
#
# Used internally by pkg_mkIndex to compare the extension of a file to a given
# extension. On Windows, it uses a case-insensitive comparison because the
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # parray: # Print the contents of a global array on stdout. # # Copyright © 1991-1993 The Regents of the University of California. # Copyright © 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# parray:
# Print the contents of a global array on stdout.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
proc parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
return -code error "\"$a\" isn't an array"
}
set maxl 0
|
| ︙ | ︙ |
|
| > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ### ### ### ######### ######### ######### ## Overview # Heuristics to assemble a platform identifier from publicly available # information. The identifier describes the platform of the currently # running tcl shell. This is a mixture of the runtime environment and # of build-time properties of the executable itself. |
| ︙ | ︙ |
|
| > > > | > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ### ### ### ######### ######### ######### ## Overview # Higher-level commands which invoke the functionality of this package # for an arbitrary tcl shell (tclsh, wish, ...). This is required by a # repository as while the tcl shell executing packages uses the same # platform in general as a repository application there can be |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # safe.tcl -- # # This file provide a safe loading/sourcing mechanism for safe interpreters. # It implements a virtual path mecanism to hide the real pathnames from the # child. It runs in a parent interpreter and sets up data structure and # aliases that will be invoked when used from a child interpreter. # # See the safe.n man page for details. | > > > > > > > > > > > > | < < < < < < < | 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 |
# Copyright © 1996-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# safe.tcl --
#
# This file provide a safe loading/sourcing mechanism for safe interpreters.
# It implements a virtual path mecanism to hide the real pathnames from the
# child. It runs in a parent interpreter and sets up data structure and
# aliases that will be invoked when used from a child interpreter.
#
# See the safe.n man page for details.
# The implementation is based on namespaces. These naming conventions are
# followed:
# Private procs starts with uppercase.
# Public procs are exported and starts with lowercase
# Needed utilities package
package require opt 0.4.9
# Create the safe namespace
namespace eval ::safe {
# Exported API:
|
| ︙ | ︙ |
| ︙ | ︙ |
1 2 3 4 5 6 7 | # 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 | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # 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 |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It # defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, # etc. used by Tcl tests. See the tcltest man page for more # details. # # This design was based on the Tcl testing approach designed and # initially implemented by Mary Ann May-Pumphrey of Sun # Microsystems. | > > > > > > > > > > > > > < < < < < < | 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 |
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2000 Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# tcltest.tcl --
#
# This file contains support code for the Tcl test suite. It
# defines the tcltest namespace and finds and defines the output
# directory, constraints available, output and error channels,
# etc. used by Tcl tests. See the tcltest man page for more
# details.
#
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Microsystems.
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.8
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
if {$fullutf} {
| | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
if {$fullutf} {
fconfigure $outputChannel -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 |
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
if {$fullutf} {
| | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 |
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
if {$fullutf} {
fconfigure $errorChannel -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
# already there.
set outdir [normalizePath [file dirname \
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
proc ReadLoadScript {args} {
variable Option
variable fullutf
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {$fullutf} {
| | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 |
proc ReadLoadScript {args} {
variable Option
variable fullutf
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {$fullutf} {
fconfigure $tmp -encoding utf-8
}
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
|
| ︙ | ︙ | |||
1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
}
}
}
# tcltest::Asciify --
#
# Transforms the passed string to contain only printable ascii characters.
# Useful for printing to terminals. Non-printables are mapped to
# \x, \u or \U sequences, except \n.
#
| > | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
}
}
}
# tcltest::Asciify --
#
# Transforms the passed string to contain only printable ascii characters.
# Useful for printing to terminals. Non-printables are mapped to
# \x, \u or \U sequences, except \n.
#
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
ConstraintInitializer stdio {
variable fullutf
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {$fullutf} {
| | | 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 |
ConstraintInitializer stdio {
variable fullutf
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {$fullutf} {
fconfigure $f -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
|
| ︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 |
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
return
# return [Puts [lindex $args 0]]
}
2 {
| | | | 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 |
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
return
# return [Puts [lindex $args 0]]
}
2 {
# Either -nonewline or channelId has been specified
if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
} else {
set channel [lindex $args 0]
set newline \n
}
}
3 {
if {[lindex $args 0] eq "-nonewline"} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
set newline ""
}
}
}
|
| ︙ | ︙ | |||
2231 2232 2233 2234 2235 2236 2237 |
set testFile [dict get $testFrame file]
set testLine [dict get $testFrame line]
} else {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {$fullutf} {
| | | 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 |
set testFile [dict get $testFrame file]
set testLine [dict get $testFrame line]
} else {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {$fullutf} {
fconfigure $testFd -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
}
}
|
| ︙ | ︙ | |||
2262 2263 2264 2265 2266 2267 2268 |
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$processTest && $scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
| < | < < < | 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 |
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$processTest && $scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
puts [outputChannel] "---- Result should have been\
($match matching):\n[Asciify $result]"
}
}
if {$errorCodeFailure} {
puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
puts [outputChannel] "---- Error code should have been: '$errorCode'"
|
| ︙ | ︙ | |||
2948 2949 2950 2951 2952 2953 2954 |
lappend childargv $opt $value
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {$fullutf} {
| | | 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 |
lappend childargv $opt $value
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {$fullutf} {
fconfigure $pipeFd -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
{Passed\t([0-9]+)\t}
{Skipped\t([0-9]+)\t}
|
| ︙ | ︙ | |||
3150 3151 3152 3153 3154 3155 3156 |
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {$fullutf} {
| | | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 |
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {$fullutf} {
fconfigure $fd -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
|
| ︙ | ︙ | |||
3303 3304 3305 3306 3307 3308 3309 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {$fullutf} {
| | | 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 |
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {$fullutf} {
fconfigure $f -encoding utf-8
}
set data [read -nonewline $f]
close $f
return $data
}
# tcltest::bytestring --
|
| ︙ | ︙ |
|
| | > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Searching for Tcl Modules. Defines a procedure, declares it as the primary # command for finding packages, however also uses the former 'package unknown' # command as a fallback. # Locates all possible packages in a directory via a less restricted glob. The # targeted directory is derived from the name of the requested package, i.e. # the TM scan will look only at directories which can contain the requested # package. It will register all packages it found in the directory so that # future requests have a higher chance of being fulfilled by the ifneeded # database without having to come to us again. # |
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# word.tcl --
#
# This file defines various procedures for computing word boundaries in
# strings. This file is primarily needed so Tk text and entry widgets behave
# properly for different platforms.
# The following variables are used to determine which characters are
# interpreted as word characters. See bug [f1253530cdd8]. Will
# probably be removed in Tcl 9.
if {![info exists ::tcl_wordchars]} {
set ::tcl_wordchars {\w}
|
| ︙ | ︙ |
|
| < < < < < < < < < < < < < < < < < < < < |
| ︙ | ︙ | |||
14 15 16 17 18 19 20 |
*/
mp_err mp_root_n(const mp_int *a, int b, mp_int *c)
{
mp_int t1, t2, t3, a_;
int ilog2;
mp_err err;
| | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
*/
mp_err mp_root_n(const mp_int *a, int b, mp_int *c)
{
mp_int t1, t2, t3, a_;
int ilog2;
mp_err err;
if (b < 0 || (unsigned)b > (unsigned)MP_DIGIT_MAX) {
return MP_VAL;
}
/* input must be positive if b is even */
if (((b & 1) == 0) && mp_isneg(a)) {
return MP_VAL;
}
|
| ︙ | ︙ |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
cannot compute difference between binary files
|
| < < < < < < | > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 2002-2008 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.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem
# uses the standard Unix build system in tcl/unix (which can be used directly instead of this
# if you are not using the tk/macosx projects).
#
#-------------------------------------------------------------------------------------------------------
# customizable settings
DESTDIR ?=
INSTALL_ROOT ?= ${DESTDIR}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | // Copyright (c) 2007-2008 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. // You may distribute and/or modify this program under the terms of the GNU // Affero General Public License as published by the Free Software Foundation, // either version 3 of the License, or (at your option) any later version. // // See the file "COPYING" for information on usage and redistribution // of this file, and for a DISCLAIMER OF ALL WARRANTIES. // Tcl-Common.xcconfig -- // // This file contains the Xcode build settings comon to all // project configurations in Tcl.xcodeproj. HEADER_SEARCH_PATHS = "$(DERIVED_FILE_DIR)/tcl" $(HEADER_SEARCH_PATHS) OTHER_LDFLAGS = -headerpad_max_install_names -sectcreate __TEXT __info_plist "$(DERIVED_FILE_DIR)/tcl/Tclsh-Info.plist" $(OTHER_LDFLAGS) INSTALL_PATH = $(BINDIR) INSTALL_MODE_FLAG = go-w,a+rX GCC_PREFIX_HEADER = $(DERIVED_FILE_DIR)/tcl/tclConfig.h GCC_GENERATE_DEBUGGING_SYMBOLS = YES |
| ︙ | ︙ |
1 2 3 4 5 6 | // // Tcl-Debug.xcconfig -- // // This file contains the Xcode build settings for all Debug // project configurations in Tcl.xcodeproj. // | > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | // Copyright (c) 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. // You may distribute and/or modify this program under the terms of the GNU // Affero General Public License as published by the Free Software Foundation, // either version 3 of the License, or (at your option) any later version. // // See the file "COPYING" for information on usage and redistribution // of this file, and for a DISCLAIMER OF ALL WARRANTIES. // Tcl-Debug.xcconfig -- // // This file contains the Xcode build settings for all Debug // project configurations in Tcl.xcodeproj. // #include "Tcl-Common.xcconfig" DEBUG_INFORMATION_FORMAT = dwarf DEAD_CODE_STRIPPING = NO DEPLOYMENT_POSTPROCESSING = NO GCC_OPTIMIZATION_LEVEL = 0 |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-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. --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>@TCL_LIB_FILE@</string> <key>CFBundleGetInfoString</key> | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-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. --> <!-- You may distribute and/or modify this program under the terms of the GNU Affero General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. See the file "COPYING" for information on usage and redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>@TCL_LIB_FILE@</string> <key>CFBundleGetInfoString</key> |
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | // Copyright (c) 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. // You may distribute and/or modify this program under the terms of the GNU // Affero General Public License as published by the Free Software Foundation, // either version 3 of the License, or (at your option) any later version. // // See the file "COPYING" for information on usage and redistribution // of this file, and for a DISCLAIMER OF ALL WARRANTIES. // Tcl-Release.xcconfig -- // // This file contains the Xcode build settings for all Release // project configurations in Tcl.xcodeproj. #include "Tcl-Common.xcconfig" DEBUG_INFORMATION_FORMAT = dwarf-with-dsym DEAD_CODE_STRIPPING = YES DEPLOYMENT_POSTPROCESSING = YES GCC_OPTIMIZATION_LEVEL = 2 |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-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. --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>tclsh@TCL_VERSION@</string> <key>CFBundleGetInfoString</key> | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-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. --> <!-- You may distribute and/or modify this program under the terms of the GNU Affero General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. See the file "COPYING" for information on usage and redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>tclsh@TCL_VERSION@</string> <key>CFBundleGetInfoString</key> |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2001-2009 Apple Inc. * Copyright © 2003-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclMacOSXBundle.c -- * * This file implements functions that inspect CFBundle structures on * MacOS X. */ #include "tclPort.h" #include "tclInt.h" #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #ifndef TCL_DYLD_USE_DLFCN |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2003-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclMacOSXFCmd.c * * This file implements the MacOSX specific portion of file manipulation * subcommands of the "file" command. */ #include "tclInt.h" #ifdef HAVE_GETATTRLIST #include <sys/attr.h> #include <sys/paths.h> #include <libkern/OSByteOrder.h> #endif |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
static int GetOSTypeFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, OSType *osTypePtr);
static Tcl_Obj * NewOSTypeObj(const OSType newOSType);
static int SetOSTypeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfOSType(Tcl_Obj *objPtr);
static const Tcl_ObjType tclOSTypeType = {
| | | | | | < > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
static int GetOSTypeFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, OSType *osTypePtr);
static Tcl_Obj * NewOSTypeObj(const OSType newOSType);
static int SetOSTypeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfOSType(Tcl_Obj *objPtr);
static const Tcl_ObjType tclOSTypeType = {
"osType", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfOSType, /* updateStringProc */
SetOSTypeFromAny, /* setFromAnyProc */
0
};
enum {
kIsInvisible = 0x4000,
};
#define kFinfoIsInvisible (OSSwapHostToBigConstInt16(kIsInvisible))
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_Size length;
| | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_Size length;
string = Tcl_GetStringFromObj(objPtr, &length);
Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &ds, NULL);
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", (char *)NULL);
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 | * OSType-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfOSType( | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
* OSType-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfOSType(
Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
const size_t size = TCL_UTF_MAX * 4;
char *dst = Tcl_InitStringRep(objPtr, NULL, size);
OSType osType = (OSType) objPtr->internalRep.wideValue;
int written = 0;
Tcl_Encoding encoding;
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2001-2009, Apple Inc. * Copyright © 2005-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclMacOSXNotify.c -- * * This file contains the implementation of a merged CFRunLoop/select() * based notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. */ #include "tclInt.h" /* * In macOS 10.12 the os_unfair_lock was introduced as a replacement for the * OSSpinLock, and the OSSpinLock was deprecated. */ |
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure is what is added to the Tcl event queue when file
* handlers are ready to fire.
*/
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( | | | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 |
* Replaces any previous timer.
*
*----------------------------------------------------------------------
*/
void
TclpSetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
ThreadSpecificData *tsdPtr;
CFRunLoopTimerRef runLoopTimer;
CFTimeInterval waitTime;
tsdPtr = TCL_TSD_INIT(&dataKey);
runLoopTimer = tsdPtr->runLoopTimer;
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
if (filePtr == NULL) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
|
| ︙ | ︙ | |||
1903 1904 1905 1906 1907 1908 1909 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
| | | 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
TCL_UNUSED(void *), /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # test-performance.tcl -- # # This file provides common performance tests for comparison of tcl-speed # degradation by switching between branches. # (currently for clock ensemble only) # # ------------------------------------------------------------------------ | > > > > > > > > > > > > > < < < < < < | 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 |
#!/usr/bin/tclsh
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation by switching between branches.
# (currently for clock ensemble only)
#
# ------------------------------------------------------------------------
array set in {-time 500}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in $argv
}
## common test performance framework:
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
_test_run $reptime {
# Bad zone
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
| < < < | < | < < | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
_test_run $reptime {
# Bad zone
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
{set i 0; time { clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
# Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference)
{set i 50; time { clock scan "[incr i -1] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
}
}
proc test-ensemble-perf {{reptime 1000}} {
_test_run $reptime {
# Clock clicks (ensemble)
{clock clicks}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # comparePerf.tcl -- # # Script to compare performance data from multiple runs. # # ------------------------------------------------------------------------ # | > > > > > > > > > > > < < < | 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 | #!/usr/bin/tclsh # See the file "license.terms" for information on usage and redistribution # of this file. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------ # # comparePerf.tcl -- # # Script to compare performance data from multiple runs. # # ------------------------------------------------------------------------ # # Usage: # tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ... # # The test data from each input file is tabulated so as to compare the results # of test runs. If a PERFFILE does not exist, it is retried by adding the # .perf extension. If the --regexp is specified, only test results whose # id matches RE are examined. |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # listPerf.tcl -- # # This file provides performance tests for list operations. Run # tclsh listPerf.tcl help # for options. # ------------------------------------------------------------------------ # | > > > > > > > > > > > < < < | 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 |
#!/usr/bin/tclsh
# See the file "license.terms" for information on usage and redistribution
# of this file.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------
#
# listPerf.tcl --
#
# This file provides performance tests for list operations. Run
# tclsh listPerf.tcl help
# for options.
# ------------------------------------------------------------------------
#
# Note: this file does not use the test-performance.tcl framework as we want
# more direct control over timerate options.
catch {package require twapi}
namespace eval perf::list {
variable perfScript [file normalize [info script]]
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | # ------------------------------------------------------------------------ # # test-performance.tcl -- # # This file provides common performance tests for comparison of tcl-speed # degradation or regression by switching between branches. # # To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl". # # ------------------------------------------------------------------------ | > > > > > > > > > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#! /usr/bin/env tclsh
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------
#
# test-performance.tcl --
#
# This file provides common performance tests for comparison of tcl-speed
# degradation or regression by switching between branches.
#
# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
#
# ------------------------------------------------------------------------
namespace eval ::tclTestPerf {
# warm-up interpreter compiler env, calibrate timerate measurement functionality:
# if no timerate here - import from unsupported:
if {[namespace which -command timerate] eq {}} {
namespace inscope ::tcl::unsupported {namespace export timerate}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | #!/usr/bin/tclsh # ------------------------------------------------------------------------ # # timer-event.perf.tcl -- # # This file provides performance tests for comparison of tcl-speed # of timer events (event-driven tcl-handling). # # ------------------------------------------------------------------------ | > > > > > > > > > > > > < < < < < < < | 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 |
#!/usr/bin/tclsh
# Copyright © 2014 Serg G. Brester (aka sebres)
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------
#
# timer-event.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of timer events (event-driven tcl-handling).
#
# ------------------------------------------------------------------------
if {![namespace exists ::tclTestPerf]} {
source [file join [file dirname [info script]] test-performance.tcl]
}
namespace eval ::tclTestPerf-Timer-Event {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: exit, emphasis on finalization hangs
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test exit-1.1 {normal, quick exit} {
|
| ︙ | ︙ |
|
| < < > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Copyright © 2022 Brian Griffin
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {
|
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
test abstractlist-2.14 {error case lset multiple indicies} -constraints {testobj lstring} -body {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [lset l 2 0 1 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} -returnCodes 1 \
| | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
test abstractlist-2.14 {error case lset multiple indicies} -constraints {testobj lstring} -body {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [lset l 2 0 1 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} -returnCodes 1 \
-result {Multiple indices not supported by lstring.}
# lsort
test abstractlist-3.0 {no shimmer llength} {testobj lstring} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set len [llength $l]
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [testevalex {lset l 2 k}]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
| | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [testevalex {lset l 2 k}]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
test abstractlist-$not-4.11e {error case lset multiple indices} \
-constraints {SetelementShimmer testobj lstring testevalex} -body {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [testevalex {lset l 2 0 1 k}]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} -returnCodes 1 \
-result {Multiple indices not supported by lstring.}
# lrepeat
test abstractlist-$not-4.12 {shimmer lrepeat} -constraints {testobj lstring} -body {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [lrepeat 3 $l]
set m-isa [testobj objtype $m]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1998-1999 Scriptics Corporation.
# Copyright © 2000 Ajuba Solutions
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all.tcl" when running tcltest
# in this directory.
package prefer latest
package require tcltest 2.5
namespace import ::tcltest::*
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
info script]/...]]]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: append lappend
#
# 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.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
unset -nocomplain x
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
test append-3.6 {append surrogates} -body {
set x \uDE02
set x \uD83D$x
} -result \uD83D\uDE02
test append-3.7 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length [append x [testbytestring \x80]]
| | | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
test append-3.6 {append surrogates} -body {
set x \uDE02
set x \uD83D$x
} -result \uD83D\uDE02
test append-3.7 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length [append x [testbytestring \x80]]
} -result 1
test append-3.8 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length $x[testbytestring \x80]
} -result 1
test append-3.9 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \x80]
string length [testbytestring \xC0]$x
} -result 1
test append-3.10 {append surrogates} -body {
set x \uD83D
string range $x 0 end
append x \uDE02
} -result [string range \uD83D\uDE02 0 end]
test append-4.1 {lappend command} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: append lappend
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset x}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: apply
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2010 Ozgur Dogan Ugurlu.
# Copyright © 2010 Kevin B. Kenny.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-----------------------------------------------------------------------------
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# assemble.test --
#
# Test suite for the 'tcl::unsupported::assemble' command
# Commands covered: assemble
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
proc ulam1 {n} {
set max $n
while {$n != 1} {
if {$n > $max} {
set max $n
}
if {$n % 2} {
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
proc ulam1 {n} {
set max $n
while {$n != 1} {
if {$n > $max} {
set max $n
}
if {$n % 2} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the AssocData facility of Tcl
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > > | 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 © 1998 Lucent Technologies, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating the
# autoloading index.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
makeFile {# Test file for:
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
file delete tclIndex
file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} {1}
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
file delete tclIndex
file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} {1}
set element "{source [file join . autoMkindex.tcl]}"
test autoMkindex-1.3 {examine tclIndex} -setup {
file delete tclIndex
} -body {
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::command buried::myproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
| | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
file delete tclIndex
} -body {
auto_mkindex_parser::command buried::myproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set ::result ""
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
file delete tclIndex
} -constraints {knownBug} -body {
auto_mkindex_parser::command {buried::my proc} {name args} {
variable index
variable scriptFile
puts "my proc $name"
append index [list set auto_index([fullname $name])] \
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
file delete tclIndex
} -constraints {knownBug} -body {
auto_mkindex_parser::command {buried::my proc} {name args} {
variable index
variable scriptFile
puts "my proc $name"
append index [list set auto_index([fullname $name])] \
" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set ::result ""
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
if {[string match {set auto_index*} $r]} {
lappend dat $r
}
}
set result [lsort $dat]
close $f
set result
| | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
if {[string match {set auto_index*} $r]} {
lappend dat $r
}
}
set result [lsort $dat]
close $f
set result
} {{set auto_index(::wok::commands) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source [file join $dir ensemblecommands.tcl]]}}
removeFile ensemblecommands.tcl
test autoMkindex-4.1 {platform independent source commands} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
package provide football 1.0
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
} -cleanup {
catch {close $f}
removeFile [file join pkg samename.tcl]
removeDirectory pkg
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
} -cleanup {
catch {close $f}
removeFile [file join pkg samename.tcl]
removeDirectory pkg
} -result {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}
test autoMkindex-5.1 {escape magic tcl chars in general code} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
set dollar2 \
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
auto_mkindex . pkg/magicchar.tcl
set f [open tclIndex r]
lindex [split [string trim [read $f]] "\n"] end
} -cleanup {
catch {close $f}
removeFile [file join pkg magicchar.tcl]
removeDirectory pkg
| | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
auto_mkindex . pkg/magicchar.tcl
set f [open tclIndex r]
lindex [split [string trim [read $f]] "\n"] end
} -cleanup {
catch {close $f}
removeFile [file join pkg magicchar.tcl]
removeDirectory pkg
} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
file delete tclIndex
makeDirectory pkg
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
set result {}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the tclBasic.c source file. Tests appear in # the same order as the C code that they test. The set of tests is # currently incomplete since it currently includes only new tests for # code changed for the addition of Tcl namespaces. Other variable- # related tests appear in several other test files including # assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, # and trace.test. # # 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 20 21 22 23 24 25 26 27 28 29 30 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the tclBasic.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
# and trace.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < > > > > > > > > > > | 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 © 2023 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Test cases for large sized data
#
# These are very rudimentary tests for large size arguments to commands.
# They do not exercise all possible code paths such as shared/unshared Tcl_Objs,
# literal/variable arguments etc.
# They do however test compiled and uncompiled execution.
if {"::tcltest" ni [namespace children]} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
} \xCD\xCC\xCC\x3F
test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} {
binary format R Inf
| | | | 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 |
} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
} \xCD\xCC\xCC\x3F
test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} {
binary format R Inf
} \x7f\x80\x00\x00
test binary-53.21 {Tcl_BinaryObjCmd: float Inf} {} {
binary format r Inf
} \x00\x00\x80\x7f
test binary-53.22 {Binary float Inf round trip} -body {
binary scan [binary format R Inf] R inf
binary scan [binary format R -Inf] R inf_
list $inf $inf_
} -result {Inf -Inf}
test binary-53.23 {Binary float round to FLT_MAX} -body {
binary scan [binary format H* 7f7fffff] R fltmax
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright © 2005 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the Tcl built-in 'chan'
# command. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
} -returnCodes error -result "wrong # args: should be \"chan configure channel ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar Ā
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
| | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
} -returnCodes error -result "wrong # args: should be \"chan configure channel ?-option value ...?\""
test chan-4.2 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar Ā
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.3 {chan command: [Bug 800753]} -body {
chan configure stdout -eofchar \x00
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.4 {chan command: check valid inValue, no outValue} -body {
chan configure stdout -eofchar [list \x27 {}]
} -result {}
test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
chan configure stdout -eofchar [list \x27 \x80]
} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character}
test chan-4.6 {chan command: check no inValue, valid outValue} -body {
chan configure stdout -eofchar [list {} \x27]
|
| ︙ | ︙ |
|
| < < < < < < < < > > > > > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# 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.
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::io {
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 |
chan configure $f -encoding shiftjis
list [chan gets $f line] $line [chan eof $f]
} -cleanup {
chan close $f
} -result {10 1234567890 0}
test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
set x ""
| | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
chan configure $f -encoding shiftjis
list [chan gets $f line] $line [chan eof $f]
} -cleanup {
chan close $f
} -result {10 1234567890 0}
test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup {
set x ""
} -constraints testchannel -body {
set f [open $path(test1) w]
chan configure $f -translation binary
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
|
| ︙ | ︙ | |||
5272 5273 5274 5275 5276 5277 5278 |
} -cleanup {
chan close $s1
chan close $s2
} -result {auto crlf}
test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l ""
| | | | 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 |
} -cleanup {
chan close $s1
chan close $s2
} -result {auto crlf}
test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l ""
} -constraints unix -body {
set f1 [open $path(test1) w+]
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar {O {}}
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar D
lappend l [chan configure $f1 -eofchar]
} -cleanup {
chan close $f1
} -result {{} O D}
test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l [list]
} -body {
set f1 [open $path(test1) w+]
chan configure $f1 -eofchar {O {}}
lappend l [chan configure $f1 -eofchar]
chan configure $f1 -eofchar D
|
| ︙ | ︙ | |||
6703 6704 6705 6706 6707 6708 6709 |
return $result
} -result {0 0 ok}
test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
| | | > | | 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 |
return $result
} -result {0 0 ok}
test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -encoding utf-8 -translation lf -blocking 0
chan configure $f2 -encoding utf-8 -translation cr -blocking 0
chan copy $f1 $f2 -size 40
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
chan close $f2
# the file size is 41 because "©" is encoded in two bytes
lappend result [file size $path(test1)]
} -result {0 0 41}
test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
file delete $path(test1)
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation binary -blocking 0
|
| ︙ | ︙ | |||
6804 6805 6806 6807 6808 6809 6810 |
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan configure $f1 -translation lf
chan puts $f1 "
chan puts ready
chan gets stdin
set f1 \[open [list $thisScript] r\]
| | | | > | | 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 |
} -constraints {stdio fcopy} -body {
set f1 [open $path(pipe) w]
chan configure $f1 -translation lf
chan puts $f1 "
chan puts ready
chan gets stdin
set f1 \[open [list $thisScript] r\]
chan configure \$f1 -encoding utf-8 -translation lf
chan puts \[chan read \$f1 100\]
chan close \$f1
"
chan close $f1
set f1 [openpipe r+ $path(pipe)]
chan configure $f1 -encoding utf-8 -translation lf
chan gets $f1
chan puts $f1 ready
chan flush $f1
set f2 [open $path(test1) w]
chan configure $f2 -encoding utf-8 -translation lf
set s0 [chan copy $f1 $f2 -size 40]
catch {chan close $f1}
chan close $f2
# the file size is 41 because "©" is encoded in two bytes
list $s0 [file size $path(test1)]
} -result {40 41}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
chan configure $out -encoding koi8-r -translation lf
|
| ︙ | ︙ |
|
| < < < < < < < < |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
}]} {
# nothing to be done (registry loaded on demand)
}
}
package require msgcat 1.4
testConstraint detroit \
[expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}]
testConstraint y2038 \
[expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]
# Test with both validity modes - validate on / off:
| > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
}]} {
# nothing to be done (registry loaded on demand)
}
}
package require msgcat 1.4
set clockns [namespace ensemble configure clock -namespace]
testConstraint notclassic 1
testConstraint detroit \
[expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}]
testConstraint y2038 \
[expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]
# Test with both validity modes - validate on / off:
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 | # autogenerated by 'tools/makeTestCases.tcl'. DO NOT EDIT CODE BETWEEN # '# BEGIN' and '# END'. # Define a fictitious locale, 'en_US_roman', for formatting of clock # strings with localized numerics and eras. This locale will be used # in testing the 'clock' command. | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
# autogenerated by 'tools/makeTestCases.tcl'. DO NOT EDIT CODE BETWEEN
# '# BEGIN' and '# END'.
# Define a fictitious locale, 'en_US_roman', for formatting of clock
# strings with localized numerics and eras. This locale will be used
# in testing the 'clock' command.
namespace eval ${clockns} {
::msgcat::mcmset en_US_roman {
LOCALE_ERAS {
{-62164627200 {} 0}
{-59008867200 c 100}
{-55853107200 cc 200}
{-52697347200 ccc 300}
{-49541587200 cd 400}
|
| ︙ | ︙ | |||
232 233 234 235 236 237 238 |
}
}
#----------------------------------------------------------------------
#
# The tests for the Windows platform are careful *not* to muck with
# the system registry. Instead, the 'registry' command is overridden
| | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
}
}
#----------------------------------------------------------------------
#
# The tests for the Windows platform are careful *not* to muck with
# the system registry. Instead, the 'registry' command is overridden
# in the namespace for the clock implementation.
#
#----------------------------------------------------------------------
namespace eval ::testClock {
namespace export registry
set reg \
[dict create \
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 274 275 276 277 |
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Base test cases:
# no lazy creation of clock-ensemble (interim, bug [9889f96f4da77e3b], [31fd84270644f67d]),
# so ensemble created implicitely in init.tcl
| > > | > | | | | > | > | | | | > | > | | | > | > | | 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 |
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# START TESTS MARKER
# Base test cases:
# no lazy creation of clock-ensemble (interim, bug [9889f96f4da77e3b], [31fd84270644f67d]),
# so ensemble created implicitely in init.tcl
test clock-0.1 {
initial: auto-loading of ensemble and stubs on demand
} -constraints notclassic -setup {
set i [interp create]; # because clock can be used somewhere, test it in new interp:
} -body {
$i eval [string map [list @clockns@ $clockns] {
lappend ret ens:[namespace ensemble exists ::clock]
clock seconds; # init ensemble (but not yet stubs, loading of clock.tcl retarded)
lappend ret ens:[namespace ensemble exists ::clock]
lappend ret stubs:[expr {[namespace which -command @clockns@::GetSystemTimeZone] ne ""}]
clock format now; # clock.tcl stubs expected
lappend ret stubs:[expr {[namespace which -command @clockns@::GetSystemTimeZone] ne ""}]
}]
} -cleanup {
interp delete $i
} -result {ens:1 ens:1 stubs:0 stubs:1}
test clock-0.1a {
initial: safe interpreter shares clock command with parent
} -constraints notclassic -setup {
set i [interp create]
$i eval {set sci [interp create -safe]}
} -body {
$i eval [string map [list @clockns@ $clockns] {
lappend ret ens:[namespace ensemble exists ::clock]
$sci eval { clock seconds }; # init ensemble (but not yet stubs, loading of clock.tcl retarded)
lappend ret ens:[namespace ensemble exists ::clock]
lappend ret stubs:[expr {[namespace which -command @clockns@::GetSystemTimeZone] ne ""}]
$sci eval { clock format now }; # clock.tcl stubs expected
lappend ret stubs:[expr {[namespace which -command @clockns@::GetSystemTimeZone] ne ""}]
}]
} -cleanup {
interp delete $i
} -result {ens:1 ens:1 stubs:0 stubs:1}
test clock-0.2 {
initial: loading of format/locale does not overwrite interp state (errorInfo)
} -constraints notclassic -setup {
# be sure - we have no cached locale/msgcat, etc:
if {[namespace which -command ${clockns}::ClearCaches] ne ""} {
${clockns}::ClearCaches
}
} -body {
if {[catch {
return -level 0 -code error -errorcode {EXPERR TEST-ERROR} -errorinfo "ERROR expected error" test
}]} {
clock format now -locale de; # should not overwrite error code/info
list $::errorCode $::errorInfo
}
} -result {{EXPERR TEST-ERROR} {ERROR expected error}}
# Test some of the basics of [clock format]
set syntax "clockval|now ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"
test clock-1.0 "clock format - wrong # args" notclassic {
list [catch {clock format} msg] $msg $::errorCode
} [subst {1 {wrong # args: should be "clock format $syntax"} {CLOCK wrongNumArgs}}]
test clock-1.0.1 {
clock format - wrong # args (compiled ensemble with invalid syntax)
} notclassic {
list [catch {clock format 0 -too-few-options-4-test} msg] $msg $::errorCode
} [subst {1 {wrong # args: should be "clock format $syntax"} {CLOCK wrongNumArgs}}]
test clock-1.1 "clock format - bad time" notclassic {
list [catch {clock format foo} msg opt] $msg [dict getd $opt -errorcode {}]
} {1 {bad seconds "foo": must be now or integer} {CLOCK badOption foo}}
test clock-1.2 "clock format - bad gmt val" {
list [catch {clock format 0 -gmt foo} msg] $msg
} {1 {expected boolean value but got "foo"}}
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
clock format 0 -g true -f "%Y-%m-%d"
} 1970-01-01
test clock-1.7.1 "clock format - command abbreviations (compat regression test)" {
clock f 0 -g 1 -f "%Y-%m-%d"
} 1970-01-01
| | | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 |
clock format 0 -g true -f "%Y-%m-%d"
} 1970-01-01
test clock-1.7.1 "clock format - command abbreviations (compat regression test)" {
clock f 0 -g 1 -f "%Y-%m-%d"
} 1970-01-01
test clock-1.8 "clock format now" notclassic {
# give one second more for test (if on boundary of the current second):
set n [clock format [clock seconds] -g 1 -f "%s"]
expr {[clock format now -g 1 -f "%s"] in [list $n [incr n]]}
} 1
test clock-1.9 "clock arguments: option doubly present" notclassic {
list [catch {clock format 0 -gmt 1 -gmt 0} result] $result
} {1 {bad option "-gmt": doubly present}}
test clock-1.10 {clock format: text with token (bug [a858d95f4bfddafb])} {
clock format 0 -format text(%d) -gmt 1
} {text(01)}
|
| ︙ | ︙ | |||
15381 15382 15383 15384 15385 15386 15387 |
test clock-4.96 { format time of day 23:59:59 } {
clock format 86399 \
-format {%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+} \
-locale en_US_roman \
-gmt true
} {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan 1 23:59:59 GMT 1970}
| | | | | | | | | | 15394 15395 15396 15397 15398 15399 15400 15401 15402 15403 15404 15405 15406 15407 15408 15409 15410 15411 15412 15413 15414 15415 15416 15417 15418 15419 15420 15421 15422 15423 15424 15425 15426 15427 15428 15429 15430 15431 15432 15433 |
test clock-4.96 { format time of day 23:59:59 } {
clock format 86399 \
-format {%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+} \
-locale en_US_roman \
-gmt true
} {23 xxiii 11 xi 23 xxiii 11 xi 59 lix PM pm 11:59:59 pm 23:59 59 lix 23:59:59 23:59:59 xxiii h lix m lix s Thu Jan 1 23:59:59 GMT 1970}
test clock-4.97.1 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 0 -format {%J %EJ %Ej} -gmt true
} {2440588 2440588.0 2440587.5}
test clock-4.97.2 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 43200 -format {%J %EJ %Ej} -gmt true
} {2440588 2440588.5 2440588.0}
test clock-4.97.3 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 86399 -format {%J %EJ %Ej} -gmt true
} {2440588 2440588.99998843 2440588.49998843}
test clock-4.97.4 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 86400 -format {%J %EJ %Ej} -gmt true
} {2440589 2440589.0 2440588.5}
test clock-4.97.5 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 129599 -format {%J %EJ %Ej} -gmt true
} {2440589 2440589.49998843 2440588.99998843}
test clock-4.97.6 { format JDN/JD (calendar and astronomical) } notclassic {
clock format 129600 -format {%J %EJ %Ej} -gmt true
} {2440589 2440589.5 2440589.0}
test clock-4.97.7 { format JDN/JD (calendar and astronomical) } notclassic {
set i 1548249092
list \
[clock format $i -format {%J %EJ %Ej} -gmt true] \
[clock format [incr i] -format {%J %EJ %Ej} -gmt true] \
[clock format [incr i] -format {%J %EJ %Ej} -gmt true]
} {{2458507 2458507.54967593 2458507.04967593} {2458507 2458507.5496875 2458507.0496875} {2458507 2458507.54969907 2458507.04969907}}
test clock-4.97.8 { format JDN/JD (calendar and astronomical) } notclassic {
set res {}
foreach i {
-172800 -129600 -86400 -43200
-1 0 1 21600 43199 43200 86399
86400 86401 108000 129600 172800
} {
lappend res $i [clock format [expr {-210866803200 - $i}] \
|
| ︙ | ︙ | |||
15435 15436 15437 15438 15439 15440 15441 |
86399 {B.C.E. 4714-12-31 00:00:01 -- -000001 -0.99998843 -1.49998843} \
86400 {B.C.E. 4714-12-31 00:00:00 -- -000001 -1.0 -1.5} \
86401 {B.C.E. 4714-12-30 23:59:59 -- -000002 -1.00001157 -1.50001157} \
108000 {B.C.E. 4714-12-30 18:00:00 -- -000002 -1.25 -1.75} \
129600 {B.C.E. 4714-12-30 12:00:00 -- -000002 -1.5 -2.0} \
172800 {B.C.E. 4714-12-30 00:00:00 -- -000002 -2.0 -2.5} \
]
| | | 15448 15449 15450 15451 15452 15453 15454 15455 15456 15457 15458 15459 15460 15461 15462 |
86399 {B.C.E. 4714-12-31 00:00:01 -- -000001 -0.99998843 -1.49998843} \
86400 {B.C.E. 4714-12-31 00:00:00 -- -000001 -1.0 -1.5} \
86401 {B.C.E. 4714-12-30 23:59:59 -- -000002 -1.00001157 -1.50001157} \
108000 {B.C.E. 4714-12-30 18:00:00 -- -000002 -1.25 -1.75} \
129600 {B.C.E. 4714-12-30 12:00:00 -- -000002 -1.5 -2.0} \
172800 {B.C.E. 4714-12-30 00:00:00 -- -000002 -2.0 -2.5} \
]
test clock-4.97.9 { format JDN/JD (calendar and astronomical) } notclassic {
set res {}
foreach i {
-86400 -43200
-1 0 1
43199 43200 43201 86400
} {
lappend res $i [clock format [expr {653133196800 + $i}] \
|
| ︙ | ︙ | |||
18698 18699 18700 18701 18702 18703 18704 |
clock scan {2147483648} -format %s -gmt true
} 2147483648
test clock-6.8 {input of seconds} {
clock scan {9223372036854775807} -format %s -gmt true
} 9223372036854775807
| | | | > | > | | | 18711 18712 18713 18714 18715 18716 18717 18718 18719 18720 18721 18722 18723 18724 18725 18726 18727 18728 18729 18730 18731 18732 18733 18734 18735 18736 18737 18738 18739 18740 18741 18742 18743 18744 18745 18746 18747 18748 18749 18750 18751 18752 18753 18754 18755 18756 18757 18758 18759 18760 18761 18762 18763 18764 18765 18766 18767 18768 18769 18770 |
clock scan {2147483648} -format %s -gmt true
} 2147483648
test clock-6.8 {input of seconds} {
clock scan {9223372036854775807} -format %s -gmt true
} 9223372036854775807
test clock-6.8b "clock scan - bad base" notclassic {
list [catch {clock scan "" -base foo -gmt 1} msg opt] $msg [dict getd $opt -errorcode {}]
} {1 {bad seconds "foo": must be now or integer} {CLOCK badOption foo}}
test clock-6.9 {input of seconds - overflow} {
list [catch {clock scan -9223372036854775809 -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
test clock-6.10 {input of seconds - overflow} notclassic {
list [catch {clock scan 9223372036854775808 -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
foreach sign {{} -} {
test clock-6.10a$sign {input of seconds - overflow, bug [1f40aa83c5]} {
list [catch {clock scan ${sign}27670116110564327423 -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
test clock-6.10b$sign {input of seconds - overflow, bug [1f40aa83c5]} {
list [catch {clock scan ${sign}27670116110564327424 -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
test clock-6.10c$sign {input of seconds - no overflow, bug [1f40aa83c5]} {
list [catch {clock scan ${sign}[string repeat 9 18] -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} [list 0 ${sign}[string repeat 9 18] {}]
test clock-6.10d$sign {input of seconds - overflow, bug [1f40aa83c5]} {
list [catch {clock scan ${sign}[string repeat 9 19] -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
# both fololowing freescan test don't generate overflow error,
# since it is a free scan, thus the token is simply not recognized further in yacc lexer,
# therefore we get parse error (can be surely changed latter):
test clock-6.10e$sign {input of seconds - overflow (but since freescan parse error, but not boom), bug [1f40aa83c5]
} -constraints notclassic -body {
list [catch {clock scan ${sign}27670116110564327423 -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} -match glob -result {1 {unable to convert date-time string "*": syntax error *} {TCL VALUE DATE PARSE}}
test clock-6.10f$sign {input of seconds - overflow (but since freescan parse error, but not boom), bug [1f40aa83c5]
} -constraints notclassic -body {
list [catch {clock scan ${sign}27670116110564327424 -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} -match glob -result {1 {unable to convert date-time string "*": syntax error *} {TCL VALUE DATE PARSE}}
}; unset sign
test clock-6.11 {input of seconds - two values} {
clock scan {1 2} -format {%s %s} -gmt true
} 2
test clock-6.12.0 {input of short forms of locale token (%b)} notclassic {
list [clock scan "12 Ja 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1] \
[clock scan "12 Au 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1]
} {979257600 997574400}
test clock-6.12.1 {input of all forms of unambiguous short locale token (%b)} notclassic {
# find all unambiguous short forms and check it'll be scanned successful and correctly:
set months {January February March April May June July August September October November December}
set res {}
foreach mon $months {
set i 0
while {[incr i] < [string length $mon]} {
# short month form:
|
| ︙ | ︙ | |||
18771 18772 18773 18774 18775 18776 18777 |
if {$t ne $e} {
lappend res "unexpected result converting $s, expected \"$e\", got \"$t\""
}
}
}
set res
} {}
| | | | | | 18786 18787 18788 18789 18790 18791 18792 18793 18794 18795 18796 18797 18798 18799 18800 18801 18802 18803 18804 18805 18806 18807 18808 18809 18810 18811 18812 18813 18814 18815 18816 18817 18818 18819 18820 18821 18822 18823 18824 18825 18826 |
if {$t ne $e} {
lappend res "unexpected result converting $s, expected \"$e\", got \"$t\""
}
}
}
set res
} {}
test clock-6.13 {input of lowercase locale token (%b)} notclassic {
list [clock scan "12 ja 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1] \
[clock scan "12 au 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1]
} {979257600 997574400}
test clock-6.14 {input of uppercase locale token (%b)} notclassic {
list [clock scan "12 JA 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1] \
[clock scan "12 AU 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1]
} {979257600 997574400}
test clock-6.15 {input of ambiguous short locale token (%b)} {
list [catch {
clock scan "12 J 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1
} result] $result $errorCode
} {1 {input string does not match supplied format} {CLOCK badInputString}}
test clock-6.16 {input of ambiguous short locale token (%b)} {
list [catch {
clock scan "12 Ju 2001" -format "%d %b %Y" -locale en_US_roman -gmt 1
} result] $result $errorCode
} {1 {input string does not match supplied format} {CLOCK badInputString}}
test clock-6.17 {spaces are always optional in non-strict mode (default)} notclassic {
list [clock scan "2009-06-30T18:30:00+02:00" -format "%Y-%m-%dT%H:%M:%S%z" -gmt 1] \
[clock scan "2009-06-30T18:30:00 +02:00" -format "%Y-%m-%dT%H:%M:%S%z" -gmt 1] \
[clock scan "2009-06-30T18:30:00Z" -format "%Y-%m-%dT%H:%M:%S%z" -timezone CET] \
[clock scan "2009-06-30T18:30:00 Z" -format "%Y-%m-%dT%H:%M:%S%z" -timezone CET]
} {1246379400 1246379400 1246386600 1246386600}
test clock-6.18 {zone token (%z) is optional} notclassic {
list [clock scan "2009-06-30T18:30:00 -01:00" -format "%Y-%m-%dT%H:%M:%S%z" -gmt 1] \
[clock scan "2009-06-30T18:30:00" -format "%Y-%m-%dT%H:%M:%S%z" -gmt 1] \
[clock scan " 2009-06-30T18:30:00 " -format "%Y-%m-%dT%H:%M:%S%z" -gmt 1] \
} {1246390200 1246386600 1246386600}
test clock-6.19 {no token parsing} {
list [catch { clock scan "%E%O%" -format "%E%O%" }] \
|
| ︙ | ︙ | |||
18836 18837 18838 18839 18840 18841 18842 |
if {$i != $i2} {
lappend wrong "$d -- ($i != $i2) -- [clock format $i -g 1]"
}
incr i $step
}
join $wrong \n
}
| | | > | > | | | | > | 18851 18852 18853 18854 18855 18856 18857 18858 18859 18860 18861 18862 18863 18864 18865 18866 18867 18868 18869 18870 18871 18872 18873 18874 18875 18876 18877 18878 18879 18880 18881 18882 18883 18884 18885 18886 18887 18888 18889 |
if {$i != $i2} {
lappend wrong "$d -- ($i != $i2) -- [clock format $i -g 1]"
}
incr i $step
}
join $wrong \n
}
test clock-6.21.0 {Stardate 0 day} notclassic {
list [set d [clock format -757382400 -format "%Q" -gmt 1]] \
[clock scan $d -format "%Q" -gmt 1]
} [list "Stardate 00000.0" -757382400]
test clock-6.21.0.1 {Stardate 0.1 - 1.9 (test negative clock value -> positive Stardate)
} notclassic {
_testStarDates -757382400 2 0.1
} {}
test clock-6.21.0.2 {Stardate 10000.1 - 10002.9 (test negative clock value -> positive Stardate)
} notclassic {
_testStarDates [clock scan "Stardate 10000.1" -f %Q -g 1] 3 0.1
} {}
test clock-6.21.0.3 {Stardate 80000.1 - 80002.9 (test positive clock value)} notclassic {
_testStarDates [clock scan "Stardate 80001.1" -f %Q -g 1] 3 0.1
} {}
test clock-6.21.1 {Stardate} notclassic {
list [set d [clock format 1482857280 -format "%Q" -gmt 1]] \
[clock scan $d -format "%Q" -gmt 1]
} [list "Stardate 70986.7" 1482857280]
test clock-6.21.2 {Stardate next time} notclassic {
list [set d [clock format 1482865920 -format "%Q" -gmt 1]] \
[clock scan $d -format "%Q" -gmt 1]
} [list "Stardate 70986.8" 1482865920]
test clock-6.21.3 {Stardate correct scan over year (leap year, begin, middle and end of the year)
} notclassic {
_testStarDates [clock scan "01.01.2016" -f "%d.%m.%Y" -g 1] [expr {366*2}] 1
} {}
rename _testStarDates {}
test clock-6.22.1 {Greedy match} {
clock format [clock scan "111" -format "%d%m%y" -gmt 1] -locale en -gmt 1
} {Mon Jan 01 00:00:00 GMT 2001}
|
| ︙ | ︙ | |||
18998 18999 19000 19001 19002 19003 19004 |
set J0m24h [scan [clock format $s0m24h -format %J -gmt true] %lld]
set s0m1s [clock add $s0 -1 seconds -timezone :UTC]
set J0m1s [scan [clock format $s0m1s -format %J -gmt true] %lld]
list $s0m1d $s0m24h $J0m24h $s0m1s $J0m1s $s0 $J0 \
[::tcl::mathop::== $s0m1d $s0m24h] [::tcl::mathop::== $J0m24h $J0m1s]
} [list -210866889600 -210866889600 -1 -210866803201 -1 -210866803200 0 1 1]
| | > | | | | | | | | | > | > | > | 19016 19017 19018 19019 19020 19021 19022 19023 19024 19025 19026 19027 19028 19029 19030 19031 19032 19033 19034 19035 19036 19037 19038 19039 19040 19041 19042 19043 19044 19045 19046 19047 19048 19049 19050 19051 19052 19053 19054 19055 19056 19057 19058 19059 19060 19061 19062 19063 19064 19065 19066 19067 19068 19069 19070 19071 19072 19073 19074 19075 19076 19077 19078 19079 19080 19081 19082 19083 19084 19085 19086 19087 19088 19089 19090 19091 19092 19093 19094 19095 19096 19097 19098 19099 19100 19101 19102 19103 19104 19105 19106 19107 19108 |
set J0m24h [scan [clock format $s0m24h -format %J -gmt true] %lld]
set s0m1s [clock add $s0 -1 seconds -timezone :UTC]
set J0m1s [scan [clock format $s0m1s -format %J -gmt true] %lld]
list $s0m1d $s0m24h $J0m24h $s0m1s $J0m1s $s0 $J0 \
[::tcl::mathop::== $s0m1d $s0m24h] [::tcl::mathop::== $J0m24h $J0m1s]
} [list -210866889600 -210866889600 -1 -210866803201 -1 -210866803200 0 1 1]
test clock-7.11.1 {Calendar vs Astronomical Julian Day (without and with time fraction)
} notclassic {
list \
[clock scan {2440588} -format {%J} -gmt true] \
[clock scan {2440588} -format {%EJ} -gmt true] \
[clock scan {2440588} -format {%Ej} -gmt true] \
[clock scan {2440588.5} -format {%EJ} -gmt true] \
[clock scan {2440588.5} -format {%Ej} -gmt true] \
} {0 0 43200 43200 86400}
test clock-7.11.2 {Astronomical JDN/JD} notclassic {
clock scan 0 -format %Ej -gmt true
} -210866760000
test clock-7.12 {Astronomical JDN/JD} notclassic {
clock format [clock scan 2440587.5 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "1970-01-01 00:00:00"
test clock-7.13 {Astronomical JDN/JD} notclassic {
clock format [clock scan 2451544.5 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "2000-01-01 00:00:00"
test clock-7.13.1 {Astronomical JDN/JD} notclassic {
clock format [clock scan 2488069.5 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "2100-01-01 00:00:00"
test clock-7.14 {Astronomical JDN/JD} notclassic {
clock format [clock scan 5373483.5 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "9999-12-31 00:00:00"
test clock-7.14.1 {Astronomical JDN/JD} notclassic {
clock format [clock scan 5373484 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "9999-12-31 12:00:00"
test clock-7.14.2 {Astronomical JDN/JD} notclassic {
clock format [clock scan 5373484.49999 -format %Ej -gmt true] \
-format "%Y-%m-%d %T" -gmt true
} "9999-12-31 23:59:59"
test clock-7.15 {Astronomical JDN/JD, bad} {
list [catch {
clock scan bogus -format %Ej
} result] $result $errorCode
} {1 {input string does not match supplied format} {CLOCK badInputString}}
test clock-7.16 {Astronomical JDN/JD, overflow} notclassic {
list [catch {
clock scan 5373484.5 -format %Ej
} result] $result $errorCode \
[catch {
clock scan 5373485 -format %Ej
} result] $result $errorCode \
[catch {
clock scan 2147483648 -format %Ej
} result] $result $errorCode \
[catch {
clock scan 2147483648.5 -format %Ej
} result] $result $errorCode
} [lrepeat 4 1 {requested date too large to represent} {CLOCK dateTooLarge}]
test clock-7.18 {Astronomical JDN/JD, same precedence as seconds (last wins
} notclassic {
list [clock scan {2440588 86400} -format {%Ej %s} -gmt true] \
[clock scan {2440589 0} -format {%Ej %s} -gmt true] \
[clock scan {86400 2440588} -format {%s %Ej} -gmt true] \
[clock scan {0 2440589} -format {%s %Ej} -gmt true]
} {86400 0 43200 129600}
test clock-7.19 {Astronomical JDN/JD, two values
} notclassic {
clock scan {2440588 2440589} -format {%Ej %Ej} -gmt true
} 129600
test clock-7.20 {all JDN/JD are signed (and extended accept floats)
} notclassic {
set res {}
foreach i {%J %EJ %Ej} {
lappend res [clock scan "-1" -format $i -gmt 1]
}
foreach i {%EJ %Ej} {
lappend res [clock scan "-1.5" -format $i -gmt 1]
}
|
| ︙ | ︙ | |||
21493 21494 21495 21496 21497 21498 21499 |
} 1009756800
# END testcases8
test clock-9.1 {seconds take precedence over ccyymmdd} {
clock scan {0 20000101} -format {%s %Y%m%d} -gmt true
} 0
| | > | > | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | > > | > > | > > | > > | > > | > > | > > | > | 21515 21516 21517 21518 21519 21520 21521 21522 21523 21524 21525 21526 21527 21528 21529 21530 21531 21532 21533 21534 21535 21536 21537 21538 21539 21540 21541 21542 21543 21544 21545 21546 21547 21548 21549 21550 21551 21552 21553 21554 21555 21556 21557 21558 21559 21560 21561 21562 21563 21564 21565 21566 21567 21568 21569 21570 21571 21572 21573 21574 21575 21576 21577 21578 21579 21580 21581 21582 21583 21584 21585 21586 21587 21588 21589 21590 21591 21592 21593 21594 21595 21596 21597 21598 21599 21600 21601 21602 21603 21604 21605 21606 21607 21608 21609 21610 21611 21612 21613 21614 21615 21616 21617 21618 21619 21620 21621 21622 21623 21624 21625 |
} 1009756800
# END testcases8
test clock-9.1 {seconds take precedence over ccyymmdd} {
clock scan {0 20000101} -format {%s %Y%m%d} -gmt true
} 0
test clock-9.2 {Calendar julian day takes precedence over ccyymmdd} notclassic {
list \
[clock scan {2440588 20000101} -format {%J %Y%m%d} -gmt true] \
[clock scan {2440588 20000101} -format {%EJ %Y%m%d} -gmt true]
} {0 0}
test clock-9.2.1 {
Calendar julian day (with time fraction) takes precedence over date-time
} notclassic {
list \
[clock scan {2440588.0 20000101 010203} -format {%EJ %Y%m%d %H%M%S} -gmt true] \
[clock scan {2440588.5 20000101 010203} -format {%EJ %Y%m%d %H%M%S} -gmt true]
} {0 43200}
test clock-9.3 {Astro julian day takes always precedence over date-time
} notclassic {
list \
[clock scan {2440587.5 20000101 010203} -format {%Ej %Y%m%d %H%M%S} -gmt true] \
[clock scan {2440588 20000101 010203} -format {%Ej %Y%m%d %H%M%S} -gmt true]
} {0 43200}
test clock-10.9 {seconds take precedence over ccyyddd} {
list [clock scan {0 2000001} -format {%s %Y%j} -gmt true] \
[clock scan {2000001 0} -format {%Y%j %s} -gmt true]
} {0 0}
test clock-10.10 {julian day takes precedence over ccyyddd} {
list [clock scan {2440588 2000001} -format {%J %Y%j} -gmt true] \
[clock scan {2000001 2440588} -format {%Y%j %J} -gmt true]
} {0 0}
# BEGIN testcases11
# Test precedence yyyymmdd over yyyyddd
if {!$valid_mode} {
set res {-result 0}
} else {
set res {-returnCodes error -result "unable to convert input string: ambiguous day"}
}
test clock-11.1 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 19700101002 -format %Y%m%d%j -gmt 1
} {*}$res
test clock-11.2 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01197001002 -format %m%Y%d%j -gmt 1
} {*}$res
test clock-11.3 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01197001002 -format %d%Y%m%j -gmt 1
} {*}$res
test clock-11.4 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 00219700101 -format %j%Y%m%d -gmt 1
} {*}$res
test clock-11.5 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 19700100201 -format %Y%m%j%d -gmt 1
} {*}$res
test clock-11.6 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 01197000201 -format %m%Y%j%d -gmt 1
} {*}$res
test clock-11.7 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 01197000201 -format %d%Y%j%m -gmt 1
} {*}$res
test clock-11.8 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 00219700101 -format %j%Y%d%m -gmt 1
} {*}$res
test clock-11.9 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 19700101002 -format %Y%d%m%j -gmt 1
} {*}$res
test clock-11.10 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01011970002 -format %m%d%Y%j -gmt 1
} {*}$res
test clock-11.11 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01011970002 -format %d%m%Y%j -gmt 1
} {*}$res
test clock-11.12 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 00201197001 -format %j%m%Y%d -gmt 1
} {*}$res
test clock-11.13 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 19700100201 -format %Y%d%j%m -gmt 1
} {*}$res
test clock-11.14 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01010021970 -format %m%d%j%Y -gmt 1
} {*}$res
test clock-11.15 {
precedence of ccyymmdd over ccyyddd
} -constraints notclassic -body {
clock scan 01010021970 -format %d%m%j%Y -gmt 1
} {*}$res
test clock-11.16 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 00201011970 -format %j%m%d%Y -gmt 1
} {*}$res
test clock-11.17 {precedence of ccyymmdd over ccyyddd} -body {
clock scan 19700020101 -format %Y%j%m%d -gmt 1
|
| ︙ | ︙ | |||
35755 35756 35757 35758 35759 35760 35761 |
set t [clock scan {2004-10-31 01:00:00 -0400} \
-format {%Y-%m-%d %H:%M:%S %z} \
-timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
set f1 [clock add $t 3600 seconds -timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S %z} \
-timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
} {2004-10-31 01:00:00 -0500}
| | | | | | | 35768 35769 35770 35771 35772 35773 35774 35775 35776 35777 35778 35779 35780 35781 35782 35783 35784 35785 35786 35787 35788 35789 35790 35791 35792 35793 35794 35795 35796 35797 35798 35799 35800 35801 35802 |
set t [clock scan {2004-10-31 01:00:00 -0400} \
-format {%Y-%m-%d %H:%M:%S %z} \
-timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
set f1 [clock add $t 3600 seconds -timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S %z} \
-timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
} {2004-10-31 01:00:00 -0500}
test clock-30.26 {clock add weekdays} notclassic {
set t [clock scan {2013-11-20}] ;# Wednesday
set f1 [clock add $t 3 weekdays]
set x1 [clock format $f1 -format {%Y-%m-%d}]
} {2013-11-25}
test clock-30.27 {clock add weekdays starting on Saturday} notclassic {
set t [clock scan {2013-11-23}] ;# Saturday
set f1 [clock add $t 1 weekday]
set x1 [clock format $f1 -format {%Y-%m-%d}]
} {2013-11-25}
test clock-30.28 {clock add weekdays starting on Sunday} notclassic {
set t [clock scan {2013-11-24}] ;# Sunday
set f1 [clock add $t 1 weekday]
set x1 [clock format $f1 -format {%Y-%m-%d}]
} {2013-11-25}
test clock-30.29 {clock add 0 weekdays starting on a weekend} notclassic {
set t [clock scan {2016-02-27}] ;# Saturday
set f1 [clock add $t 0 weekdays]
set x1 [clock format $f1 -format {%Y-%m-%d}]
} {2016-02-27}
test clock-30.30 {clock add weekdays and back} -constraints notclassic -body {
set n [clock seconds]
# we start on each day of the week
for {set i 0} {$i < 7} {incr i} {
set start [clock add $n $i days]
set startu [clock format $start -format %u]
# add 0 - 100 weekdays
for {set j 0} {$j < 100} {incr j} {
|
| ︙ | ︙ | |||
35848 35849 35850 35851 35852 35853 35854 |
# END testcases30
test clock-31.1 {system locale} \
-constraints win \
-setup {
| | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > < | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 35861 35862 35863 35864 35865 35866 35867 35868 35869 35870 35871 35872 35873 35874 35875 35876 35877 35878 35879 35880 35881 35882 35883 35884 35885 35886 35887 35888 35889 35890 35891 35892 35893 35894 35895 35896 35897 35898 35899 35900 35901 35902 35903 35904 35905 35906 35907 35908 35909 35910 35911 35912 35913 35914 35915 35916 35917 35918 35919 35920 35921 35922 35923 35924 35925 35926 35927 35928 35929 35930 35931 35932 35933 35934 35935 35936 35937 35938 35939 35940 35941 35942 35943 35944 35945 35946 35947 35948 35949 35950 35951 35952 35953 35954 35955 35956 35957 35958 35959 35960 35961 35962 35963 35964 35965 35966 35967 35968 35969 35970 35971 35972 35973 35974 35975 35976 35977 35978 35979 35980 35981 35982 35983 35984 35985 35986 35987 35988 35989 35990 35991 35992 35993 35994 35995 35996 35997 35998 35999 36000 36001 36002 36003 36004 36005 36006 36007 36008 36009 36010 36011 36012 36013 36014 36015 36016 36017 36018 36019 36020 36021 36022 36023 36024 36025 36026 36027 36028 36029 36030 36031 36032 36033 36034 36035 36036 36037 36038 36039 36040 36041 36042 36043 36044 36045 36046 36047 |
# END testcases30
test clock-31.1 {system locale} \
-constraints win \
-setup {
namespace eval $clockns {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
${clockns}::ClearCaches
} \
-body {
clock format 0 -timezone :UTC -locale system -format %x
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
${clockns}::ClearCaches
} \
-result [clock format 0 -timezone :UTC -locale current \
-format {%d-%b-%Y}]
test clock-31.2 {system locale} \
-constraints win \
-setup {
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
${clockns}::ClearCaches
} \
-body {
clock format 0 -timezone :UTC -locale system -format %Ex
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
${clockns}::ClearCaches
} \
-result [clock format 0 -timezone :UTC -locale current \
-format {the %d' day of %B %Y}]
test clock-31.3 {system locale} \
-constraints win \
-setup {
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
${clockns}::ClearCaches
} \
-body {
clock format 0 -timezone :UTC -locale system -format %X
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
${clockns}::ClearCaches
} \
-result [clock format 0 -timezone :UTC -locale current \
-format {%l:%M:%S %p}]
test clock-31.4 {system locale} \
-constraints win \
-setup {
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
unset env(TZ)
}
if { [info exists env(TCL_TZ)] } {
set oldTclTZ $env(TCL_TZ)
unset env(TCL_TZ)
}
${clockns}::ClearCaches
} \
-body {
clock format 0 -locale system -format %x
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if { [info exists oldTclTZ] } {
set env(TCL_TZ) $oldTclTZ
}
if { [info exists oldTZ] } {
set env(TZ) $oldTZ
}
if {$noreg} {set ${clockns}::NoRegistry {}}
${clockns}::ClearCaches
} \
-result [clock format 0 -locale current -timezone EST5 \
-format {%d-%b-%Y}]
test clock-31.5 {system locale} \
-constraints win \
-setup {
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
unset env(TZ)
}
if { [info exists env(TCL_TZ)] } {
set oldTclTZ $env(TCL_TZ)
unset env(TCL_TZ)
}
${clockns}::ClearCaches
} \
-body {
clock format 0 -locale system -format %Ex
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
if { [info exists oldTclTZ] } {
set env(TCL_TZ) $oldTclTZ
}
if { [info exists oldTZ] } {
set env(TZ) $oldTZ
}
${clockns}::ClearCaches
} \
-result [clock format 0 -locale current -timezone EST5 \
-format {the %d' day of %B %Y}]
test clock-31.6 {system locale} \
-constraints win \
-setup {
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
unset env(TZ)
}
if { [info exists env(TCL_TZ)] } {
set oldTclTZ $env(TCL_TZ)
unset env(TCL_TZ)
}
${clockns}::ClearCaches
} \
-body {
clock format 0 -locale system -format "%X %Z"
} \
-cleanup {
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
if { [info exists oldTclTZ] } {
set env(TCL_TZ) $oldTclTZ
}
if { [info exists oldTZ] } {
set env(TZ) $oldTZ
}
${clockns}::ClearCaches
} \
-result [clock format 0 -locale current -timezone EST5 \
-format {%l:%M:%S %p %Z}]
test clock-32.1 {scan/format across the Gregorian change} {
set problems {}
set t [expr { wide(-6857395200) }]
|
| ︙ | ︙ | |||
36214 36215 36216 36217 36218 36219 36220 |
set t1 $t3
}
expr { $t2 / 1000 == $t3 }
} {1}
# clock scan
set syntax "clock scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE? ?-validate boolean?"
| | | 36227 36228 36229 36230 36231 36232 36233 36234 36235 36236 36237 36238 36239 36240 36241 |
set t1 $t3
}
expr { $t2 / 1000 == $t3 }
} {1}
# clock scan
set syntax "clock scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE? ?-validate boolean?"
test clock-34.1 {clock scan tests} notclassic {
list [catch {clock scan} msg] $msg
} [subst {1 {wrong # args: should be "$syntax"}}]
test clock-34.2 {clock scan tests} {*}{
-body {clock scan "bad-string"}
-returnCodes error
-match glob
-result {unable to convert date-time string "bad-string"*}
|
| ︙ | ︙ | |||
36248 36249 36250 36251 36252 36253 36254 |
set time [clock scan "Oct 23,1992 15:00 GMT"]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.8 {clock scan tests} {
set time [clock scan "Oct 23,1992 15:00" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
| | | | | 36261 36262 36263 36264 36265 36266 36267 36268 36269 36270 36271 36272 36273 36274 36275 36276 36277 36278 36279 36280 36281 36282 36283 36284 36285 36286 36287 36288 36289 36290 |
set time [clock scan "Oct 23,1992 15:00 GMT"]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.8 {clock scan tests} {
set time [clock scan "Oct 23,1992 15:00" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} notclassic {
list [catch {clock scan "Jan 12" -bad arg} msg] $msg
} [subst {1 {bad option "-bad": must be -base, -format, -gmt, -locale, -timezone or -validate}}]
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
set time [clock scan "1/1/71" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,1971 00:00 GMT}
test clock-34.11 {clock scan tests} notclassic {
set time [clock scan "1/1/37" -gmt true]
clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true
} {Jan 01,2037 00:00 GMT}
test clock-34.11.1 {clock scan tests: same century switch} {
set times [clock scan "1/1/37" -gmt true]
} [clock scan "1/1/37" -format "%m/%d/%y" -gmt true]
test clock-34.11.2 {clock scan tests: same century switch} notclassic {
set times [clock scan "1/1/38" -gmt true]
} [clock scan "1/1/38" -format "%m/%d/%y" -gmt true]
test clock-34.11.3 {clock scan tests: same century switch} {
set times [clock scan "1/1/39" -gmt true]
} [clock scan "1/1/39" -format "%m/%d/%y" -gmt true]
test clock-34.12 {clock scan, relative times} {
set time [clock scan "Oct 23, 1992 -1 day" -gmt true]
|
| ︙ | ︙ | |||
36286 36287 36288 36289 36290 36291 36292 |
set time [clock scan "1992-10-23" -gmt true]
clock format $time -format {%b %d, %Y} -gmt true
} "Oct 23, 1992"
test clock-34.15 {clock scan, DD-Mon-YYYY format} {
set time [clock scan "23-Oct-1992" -gmt true]
clock format $time -format {%b %d, %Y} -gmt true
} "Oct 23, 1992"
| | > | > > | > | 36299 36300 36301 36302 36303 36304 36305 36306 36307 36308 36309 36310 36311 36312 36313 36314 36315 36316 36317 36318 36319 36320 36321 36322 36323 36324 36325 |
set time [clock scan "1992-10-23" -gmt true]
clock format $time -format {%b %d, %Y} -gmt true
} "Oct 23, 1992"
test clock-34.15 {clock scan, DD-Mon-YYYY format} {
set time [clock scan "23-Oct-1992" -gmt true]
clock format $time -format {%b %d, %Y} -gmt true
} "Oct 23, 1992"
test clock-34.16 {clock scan, ISO 8601 point in time format} notclassic {
set time [clock scan "19921023T235959" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.16.1a {
clock scan, ISO 8601 T literal optional (YYYYMMDDhhmmss)
} notclassic {
set time [clock scan "19921023235959" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.16.1b {
clock scan, ISO 8601 T literal optional (YYYYMMDDhhmm)
} notclassic {
set time [clock scan "199210232359" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:00"
test clock-34.16.2 {clock scan, ISO 8601 extended date time} {
set time [clock scan "1992-10-23T23:59:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
|
| ︙ | ︙ | |||
36318 36319 36320 36321 36322 36323 36324 |
set time [clock scan "1992-10-23T23:59:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.17.2c {clock scan, ISO 8601 extended date time (YYYY-MM-DD hh:mm)} {
set time [clock scan "1992-10-23 23:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:00"
| > | > > | > > | > | 36335 36336 36337 36338 36339 36340 36341 36342 36343 36344 36345 36346 36347 36348 36349 36350 36351 36352 36353 36354 36355 36356 36357 36358 36359 36360 36361 36362 36363 36364 36365 36366 36367 36368 36369 36370 36371 36372 36373 36374 36375 36376 36377 36378 36379 36380 36381 36382 36383 36384 36385 |
set time [clock scan "1992-10-23T23:59:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.17.2c {clock scan, ISO 8601 extended date time (YYYY-MM-DD hh:mm)} {
set time [clock scan "1992-10-23 23:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:00"
test clock-34.17.2d {
clock scan, ISO 8601 extended date time (YYYY-MM-DDThh:mm)
} notclassic {
set time [clock scan "1992-10-23T23:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:00"
test clock-34.17.3 {clock scan, TZ-word boundaries - Z is not TZ here } -body {
set time [clock scan "1992-10-23Z23:59:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} -returnCodes error -match glob \
-result {unable to convert date-time string*}
test clock-34.17.4 {
clock scan, TZ-word boundaries - Z is TZ UTC here
} notclassic {
set time [clock scan "1992-10-23 Z 23:59:59" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.17.5 {clock scan, ISO 8601 extended date time with UTC TZ} {
set time [clock scan "1992-10-23T23:59:59Z" -timezone :America/Detroit]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 23:59:59"
test clock-34.18 {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023T000000" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 00:00:00"
test clock-34.18.2 {clock scan, ISO 8601 extended date time} {
set time [clock scan "1992-10-23T00:00:00" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 00:00:00"
test clock-34.18.3 {clock scan, TZ-word boundaries - Z is not TZ here } -body {
set time [clock scan "1992-10-23Z00:00:00" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} -returnCodes error -match glob \
-result {unable to convert date-time string*}
test clock-34.18.4 {
clock scan, TZ-word boundaries - Z is TZ UTC here
} notclassic {
set time [clock scan "1992-10-23 Z 00:00:00" -gmt true]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 00:00:00"
test clock-34.18.5 {clock scan, ISO 8601 extended date time with UTC TZ} {
set time [clock scan "1992-10-23T00:00:00Z" -timezone :America/Detroit]
clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
} "Oct 23, 1992 00:00:00"
|
| ︙ | ︙ | |||
36397 36398 36399 36400 36401 36402 36403 |
set time [clock scan "10:59 pm CET" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
test clock-34.20.10 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
| | | | | | | | | | 36420 36421 36422 36423 36424 36425 36426 36427 36428 36429 36430 36431 36432 36433 36434 36435 36436 36437 36438 36439 36440 36441 36442 36443 36444 36445 36446 36447 36448 36449 36450 36451 36452 36453 36454 36455 36456 36457 36458 36459 36460 36461 36462 36463 36464 36465 36466 36467 36468 36469 36470 36471 36472 36473 36474 36475 36476 36477 36478 36479 36480 36481 36482 36483 36484 |
set time [clock scan "10:59 pm CET" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
test clock-34.20.10 {clock scan tests (merid and TZ)} {
set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true]
clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
} {Jan 24,1970 21:59:00 GMT}
test clock-34.20.11 {clock scan tests (complex TZ)} notclassic {
list [clock scan "GMT+1000" -base 100000000 -gmt 1] \
[clock scan "GMT+10" -base 100000000 -gmt 1] \
[clock scan "+1000" -base 100000000 -gmt 1]
} [lrepeat 3 99964000]
test clock-34.20.12 {clock scan tests (complex TZ)} notclassic {
list [clock scan "GMT-1000" -base 100000000 -gmt 1] \
[clock scan "GMT-10" -base 100000000 -gmt 1] \
[clock scan "-1000" -base 100000000 -gmt 1]
} [lrepeat 3 100036000]
test clock-34.20.13 {clock scan tests (complex TZ)} notclassic {
list [clock scan "GMT-0000" -base 100000000 -gmt 1] \
[clock scan "GMT+0000" -base 100000000 -gmt 1] \
[clock scan "GMT" -base 100000000 -gmt 1]
} [lrepeat 3 100000000]
test clock-34.20.14 {clock scan tests (complex TZ)} notclassic {
list [clock scan "CET+1000" -base 100000000 -gmt 1] \
[clock scan "CET-1000" -base 100000000 -gmt 1]
} {99960400 100032400}
test clock-34.20.15 {clock scan tests (complex TZ)} notclassic {
list [clock scan "CET-0000" -base 100000000 -gmt 1] \
[clock scan "CET+0000" -base 100000000 -gmt 1] \
[clock scan "CET" -base 100000000 -gmt 1]
} [lrepeat 3 99996400]
test clock-34.20.16 {clock scan tests (complex TZ)} notclassic {
list [clock format [clock scan "00:00 GMT+1000" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00 GMT+10" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00 +1000" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00" -base 100000000 -timezone +1000] -gmt 1]
} [lrepeat 4 "Fri Mar 02 14:00:00 GMT 1973"]
test clock-34.20.17 {clock scan tests (complex TZ)} notclassic {
list [clock format [clock scan "00:00 GMT+0100" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00 GMT+01" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00 GMT+1" -base 100000000 -gmt 1] -gmt 1] \
[clock format [clock scan "00:00" -base 100000000 -timezone +0100] -gmt 1]
} [lrepeat 4 "Fri Mar 02 23:00:00 GMT 1973"]
test clock-34.20.18 {clock scan tests (no TZ)} {
list [clock scan "1000days" -base 100000000 -gmt 1] \
[clock scan "1000 days" -base 100000000 -gmt 1] \
[clock scan "+1000days" -base 100000000 -gmt 1] \
[clock scan "+1000 days" -base 100000000 -gmt 1] \
[clock scan "GMT +1000 days" -base 100000000 -gmt 1] \
[clock scan "00:00 GMT +1000 days" -base 100000000 -gmt 1]
} [lrepeat 6 186364800]
test clock-34.20.19 {clock scan tests (no TZ)} {
list [clock scan "-1000days" -base 100000000 -gmt 1] \
[clock scan "-1000 days" -base 100000000 -gmt 1] \
[clock scan "GMT -1000days" -base 100000000 -gmt 1] \
[clock scan "00:00 GMT -1000 days" -base 100000000 -gmt 1] \
} [lrepeat 4 13564800]
test clock-34.20.20 {clock scan tests (TZ, TZ + 1day)} notclassic {
clock scan "00:00 GMT+1000 day" -base 100000000 -gmt 1
} 100015200
test clock-34.20.21 {clock scan tests (local date of base depends on given TZ, time apllied to different day)} {
list [clock scan "23:59:59 -0100" -base 0 -timezone :CET] \
[clock scan "23:59:59 -0100" -base 0 -gmt 1] \
[clock scan "23:59:59 -0100" -base 0 -timezone -1400] \
[clock scan "23:59:59 -0100" -base 0 -timezone :Pacific/Apia]
|
| ︙ | ︙ | |||
36558 36559 36560 36561 36562 36563 36564 |
test clock-34.40.1 {clock scan, ordinal month after relative date} {
# This will fail without the bug fix (clock.tcl), as still missing
# month/julian day conversion before ordinal month increment
clock format [ \
clock scan "5 years 18 months 387 days" -base 0 -gmt 1
] -format {%a, %b %d, %Y} -gmt 1 -locale en_US_roman
} "Sat, Jul 23, 1977"
| > | > > | > | 36581 36582 36583 36584 36585 36586 36587 36588 36589 36590 36591 36592 36593 36594 36595 36596 36597 36598 36599 36600 36601 36602 36603 36604 36605 36606 |
test clock-34.40.1 {clock scan, ordinal month after relative date} {
# This will fail without the bug fix (clock.tcl), as still missing
# month/julian day conversion before ordinal month increment
clock format [ \
clock scan "5 years 18 months 387 days" -base 0 -gmt 1
] -format {%a, %b %d, %Y} -gmt 1 -locale en_US_roman
} "Sat, Jul 23, 1977"
test clock-34.40.2 {
clock scan, ordinal month after relative date
} notclassic {
# This will fail without the bug fix (clock.tcl), as still missing
# month/julian day conversion before ordinal month increment
clock format [ \
clock scan "5 years 18 months 387 days next Jan" -base 0 -gmt 1
] -format {%a, %b %d, %Y} -gmt 1 -locale en_US_roman
} "Mon, Jan 23, 1978"
test clock-34.40.3 {
clock scan, day of week after ordinal date
} notclassic {
# This will fail without the bug fix (clock.tcl), because the relative
# week day should be applied after whole date conversion
clock format [ \
clock scan "5 years 18 months 387 days next January Fri" -base 0 -gmt 1
] -format {%a, %b %d, %Y} -gmt 1 -locale en_US_roman
} "Fri, Jan 27, 1978"
|
| ︙ | ︙ | |||
36746 36747 36748 36749 36750 36751 36752 |
set res {}
lappend res [clock format [clock scan "+5 day +25 hour" \
-base [expr {$base - 6*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
lappend res [clock format [clock scan "+5 day +26 hour" \
-base [expr {$base - 6*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
} {{2016-03-27 01:00:00 CET} {2016-03-27 03:00:00 CEST}}
| > | > | 36773 36774 36775 36776 36777 36778 36779 36780 36781 36782 36783 36784 36785 36786 36787 36788 36789 |
set res {}
lappend res [clock format [clock scan "+5 day +25 hour" \
-base [expr {$base - 6*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
lappend res [clock format [clock scan "+5 day +26 hour" \
-base [expr {$base - 6*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
} {{2016-03-27 01:00:00 CET} {2016-03-27 03:00:00 CEST}}
test clock-34.69.4 {
relative time with month & day increment / daylight switch
} notclassic {
set base [clock scan "03/27/2016" -timezone CET]
set res {}
lappend res [clock format [clock scan "next Mar +5 day +25 hour" \
-base [expr {$base - 35*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
lappend res [clock format [clock scan "next Mar +5 day +26 hour" \
-base [expr {$base - 35*24*60*60}] -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
} {{2016-03-27 01:00:00 CET} {2016-03-27 03:00:00 CEST}}
|
| ︙ | ︙ | |||
36816 36817 36818 36819 36820 36821 36822 |
} {}] \n]
# clock seconds
test clock-35.1 {clock seconds tests} {
expr {[clock seconds] + 1}
concat {}
} {}
| | | | 36845 36846 36847 36848 36849 36850 36851 36852 36853 36854 36855 36856 36857 36858 36859 36860 36861 |
} {}] \n]
# clock seconds
test clock-35.1 {clock seconds tests} {
expr {[clock seconds] + 1}
concat {}
} {}
test clock-35.2 {clock seconds tests} -body {
list [catch {clock seconds foo} msg] $msg
} -match glob -result {1 {wrong # args: should be "* seconds"}}
test clock-35.3 {clock seconds tests} {
set start [clock seconds]
after 2000
set end [clock seconds]
expr {$end > $start}
} {1}
|
| ︙ | ︙ | |||
36850 36851 36852 36853 36854 36855 36856 |
set b [clock format $s -format %s -gmt 1]
set c [clock scan $s -format %s -gmt 0]
set d [clock scan $s -format %s -gmt 1]
# %s, being the difference between local and Greenwich, does not
# depend on the time zone.
list [expr {$b-$a}] [expr {$d-$c}]
} {0 0}
| | | | 36879 36880 36881 36882 36883 36884 36885 36886 36887 36888 36889 36890 36891 36892 36893 36894 36895 36896 36897 36898 36899 36900 36901 36902 |
set b [clock format $s -format %s -gmt 1]
set c [clock scan $s -format %s -gmt 0]
set d [clock scan $s -format %s -gmt 1]
# %s, being the difference between local and Greenwich, does not
# depend on the time zone.
list [expr {$b-$a}] [expr {$d-$c}]
} {0 0}
test clock-37.2 {%Es gmt testing CET} notclassic {
set s [clock scan "2017-01-10 09:00:00" -gmt 1]
set a [clock format $s -format %Es -timezone CET]
set b [clock format $s -format %Es -gmt 1]
set c [clock scan $s -format %Es -timezone CET]
set d [clock scan $s -format %Es -gmt 1]
# %Es depend on the time zone (local seconds instead of posix seconds).
list [expr {$b-$a}] [expr {$d-$c}]
} {-3600 3600}
test clock-37.3 {%Es gmt testing CEST} notclassic {
set s [clock scan "2017-05-10 09:00:00" -gmt 1]
set a [clock format $s -format %Es -timezone CET]
set b [clock format $s -format %Es -gmt 1]
set c [clock scan $s -format %Es -timezone CET]
set d [clock scan $s -format %Es -gmt 1]
# %Es depend on the time zone (local seconds instead of posix seconds).
list [expr {$b-$a}] [expr {$d-$c}]
|
| ︙ | ︙ | |||
37051 37052 37053 37054 37055 37056 37057 |
test clock-44.3 {regression test - spaces between some scan tokens are optional (TCL_CLOCK_FULL_COMPAT, no-strict only)} \
-body {
list [clock scan {9 Apr 2024} -format {%d %b%Y} -gmt 1] \
[clock scan {Tue, 9 Apr 2024 00:00:00 +0000} -format {%a, %d %b%Y %H:%M:%S %Z} -gmt 1]
} \
-result {1712620800 1712620800}
| > | | | 37080 37081 37082 37083 37084 37085 37086 37087 37088 37089 37090 37091 37092 37093 37094 37095 37096 |
test clock-44.3 {regression test - spaces between some scan tokens are optional (TCL_CLOCK_FULL_COMPAT, no-strict only)} \
-body {
list [clock scan {9 Apr 2024} -format {%d %b%Y} -gmt 1] \
[clock scan {Tue, 9 Apr 2024 00:00:00 +0000} -format {%a, %d %b%Y %H:%M:%S %Z} -gmt 1]
} \
-result {1712620800 1712620800}
test clock-44.4 {
regression test - spaces between all scan tokens are optional (TCL_CLOCK_FULL_COMPAT, no-strict only)
} -constraints notclassic -body {
list [clock scan {9 Apr 2024} -format {%d%b%Y} -gmt 1] \
[clock scan {Tue, 9 Apr 2024 00:00:00 +0000} -format {%a,%d%b%Y%H:%M:%S%Z} -gmt 1]
} \
-result {1712620800 1712620800}
test clock-45.1 {compat: scan regression on spaces (multiple spaces in format)} \
-body {
|
| ︙ | ︙ | |||
37099 37100 37101 37102 37103 37104 37105 |
test clock-45.4 {compat: scan regression on spaces (mandatory leading/trailing spaces in format)} \
-body {
list \
[catch {clock scan "11 1 120" -format "%y%m%d %H%M%S " -gmt 1} ret] $ret \
[catch {clock scan "11 1 120" -format " %y%m%d %H%M%S" -gmt 1} ret] $ret \
[catch {clock scan "11 1 120" -format " %y%m%d %H%M%S " -gmt 1} ret] $ret
} -result [lrepeat 3 1 "input string does not match supplied format"]
| | | | 37129 37130 37131 37132 37133 37134 37135 37136 37137 37138 37139 37140 37141 37142 37143 37144 37145 37146 37147 37148 37149 37150 37151 37152 37153 37154 |
test clock-45.4 {compat: scan regression on spaces (mandatory leading/trailing spaces in format)} \
-body {
list \
[catch {clock scan "11 1 120" -format "%y%m%d %H%M%S " -gmt 1} ret] $ret \
[catch {clock scan "11 1 120" -format " %y%m%d %H%M%S" -gmt 1} ret] $ret \
[catch {clock scan "11 1 120" -format " %y%m%d %H%M%S " -gmt 1} ret] $ret
} -result [lrepeat 3 1 "input string does not match supplied format"]
test clock-45.5 {regression test - freescan no int overflow} notclassic {
# note that the relative date changes currently reset the time to 00:00,
# this can be changed later (simply achievable by adding 00:00 if expected):
list \
[clock scan "+24856 days" -base 1600000000 -gmt 1] \
[clock scan "+815 months" -base 1600000000 -gmt 1] \
[clock scan "+69 years" -base 1600000000 -gmt 1] \
[clock scan "+596524 hours" -base 1600000000 -gmt 1] \
[clock scan "+35791395 minutes" -base 1600000000 -gmt 1] \
[clock scan "+2147483647 seconds" -base 1600000000 -gmt 1]
} {3747513600 3743193600 3777408000 3747486400 3747483700 3747483647}
test clock-45.6 {regression test - freescan no int overflow} notclassic {
# note that the relative date changes currently reset the time to 00:00,
# this can be changed later (simply achievable by adding 00:00 if expected):
list \
[clock scan "-24856 days" -base 2177452800 -gmt 1] \
[clock scan "-815 months" -base 2177452800 -gmt 1] \
[clock scan "-69 years" -base 2177452800 -gmt 1] \
[clock scan "-596524 hours" -base 2177452800 -gmt 1] \
|
| ︙ | ︙ | |||
37145 37146 37147 37148 37149 37150 37151 |
test clock-46.5 {regression test - good time} \
-body {
# 12:01 apm are valid input strings...
list [clock scan "12:01 am" -base 0 -gmt 1] \
[clock scan "12:01 pm" -base 0 -gmt 1]
} -result {60 43260}
| > | > > | > > | 37175 37176 37177 37178 37179 37180 37181 37182 37183 37184 37185 37186 37187 37188 37189 37190 37191 37192 37193 37194 37195 37196 37197 37198 37199 37200 37201 37202 37203 37204 37205 37206 37207 |
test clock-46.5 {regression test - good time} \
-body {
# 12:01 apm are valid input strings...
list [clock scan "12:01 am" -base 0 -gmt 1] \
[clock scan "12:01 pm" -base 0 -gmt 1]
} -result {60 43260}
test clock-46.6 {
freescan: regression test - bad time
} -constraints {notclassic valid_off} \
-body {
# 13:00 am/pm are invalid input strings...
list [clock scan "13:00 am" -base 0 -gmt 1] \
[clock scan "13:00 pm" -base 0 -gmt 1]
} -result {3600 46800}
if {!$valid_mode} {
test clock-46.7a {regression test - switch day by large not-valid time, see bug [3ee8f1c2a785f4d8]} {valid_off} {
list [clock scan 23:59:59 -base 0 -gmt 1 -format %H:%M:%S] \
[clock scan 24:00:00 -base 0 -gmt 1 -format %H:%M:%S] \
[clock scan 48:00:00 -base 0 -gmt 1 -format %H:%M:%S]
} {86399 86400 172800}
test clock-46.7b {
freescan: regression test - switch day by large not-valid time, see bug
[3ee8f1c2a785f4d8]
} {notclassic valid_off} {
list [clock scan 23:59:59 -base 0 -gmt 1] \
[clock scan 24:00:00 -base 0 -gmt 1] \
[clock scan 48:00:00 -base 0 -gmt 1]
} {86399 86400 172800}
} else {
test clock-46.8a {regression test - invalid time (hour)} {
list [catch {clock scan 24:00:00 -base 0 -gmt 1 -format %H:%M:%S} msg] $msg \
|
| ︙ | ︙ | |||
37195 37196 37197 37198 37199 37200 37201 |
}
}
set res
}
# test without and with relative offsets:
foreach {idx relstr} {"" "" "+rel" "+ 15 month + 40 days + 30 hours + 80 minutes +9999 seconds"} {
test clock-46.10$idx {freescan: validation rules: invalid time} \
| | | | | | | | | > | | > | | > | | > | | | 37230 37231 37232 37233 37234 37235 37236 37237 37238 37239 37240 37241 37242 37243 37244 37245 37246 37247 37248 37249 37250 37251 37252 37253 37254 37255 37256 37257 37258 37259 37260 37261 37262 37263 37264 37265 37266 37267 37268 37269 37270 37271 37272 37273 37274 37275 37276 37277 37278 37279 37280 37281 37282 37283 37284 37285 37286 37287 37288 37289 37290 37291 37292 37293 37294 37295 37296 37297 37298 37299 37300 37301 37302 37303 37304 37305 37306 37307 37308 37309 37310 37311 37312 37313 37314 37315 |
}
}
set res
}
# test without and with relative offsets:
foreach {idx relstr} {"" "" "+rel" "+ 15 month + 40 days + 30 hours + 80 minutes +9999 seconds"} {
test clock-46.10$idx {freescan: validation rules: invalid time} \
-constraints notclassic -body {
# 13:00 am/pm are invalid input strings...
_invalid_test {} {} "13:00 am$relstr" "13:00 pm$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid time (hour)}]
test clock-46.11$idx {freescan: validation rules: invalid time} \
-constraints notclassic -body {
# invalid minutes in input strings...
_invalid_test {} {} "23:70$relstr" "11:80 pm$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid time (minutes)}]
test clock-46.12$idx {freescan: validation rules: invalid time} \
-constraints notclassic -body {
# invalid seconds in input strings...
_invalid_test {} {} "23:00:70$relstr" "11:00:80 pm$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid time}]
test clock-46.13$idx {freescan: validation rules: invalid day} \
-constraints notclassic -body {
_invalid_test {} {} "29 Feb 2017$relstr" "30 Feb 2016$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid day}]
test clock-46.14$idx {freescan: validation rules: invalid day} \
-constraints notclassic -body {
_invalid_test {} {} "0 Feb 2017$relstr" "00 Feb 2017$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid day}]
test clock-46.15$idx {freescan: validation rules: invalid month} \
-constraints notclassic -body {
_invalid_test {} {} "13/13/2017$relstr" "00/00/2017$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid month}]
test clock-46.16$idx {freescan: validation rules: invalid day of week} \
-constraints notclassic -body {
_invalid_test {} {} "Sat Jan 02 00:00:00 1970$relstr" "Thu Jan 04 00:00:00 1970$relstr"
} -result [lrepeat 10 1 {unable to convert input string: invalid day of week}]
test clock-46.17$idx {scan: validation rules: invalid year} -constraints notclassic -setup {
set orgcfg [list -min-year [::tcl::unsupported::clock::configure -min-year] -max-year [::tcl::unsupported::clock::configure -max-year] \
-year-century [::tcl::unsupported::clock::configure -year-century] -century-switch [::tcl::unsupported::clock::configure -century-switch]]
::tcl::unsupported::clock::configure -min-year 2000 -max-year 2100 -year-century 2000 -century-switch 38
} -body {
_invalid_test {} {} "70-01-01$relstr" "1870-01-01$relstr" "9570-01-01$relstr"
} -result [lrepeat 15 1 {unable to convert input string: invalid year}] -cleanup {
::tcl::unsupported::clock::configure {*}$orgcfg
unset -nocomplain orgcfg
}
}; # foreach
test clock-46.16-pos-fs {
freescan: validation rules: valid day of week (must work for all weekdays)
} -constraints notclassic -body {
_invalid_test {:GMT -12:00 +12:00} {} {Sat, 01 Jan 2000 00:00:00} {Sun, 02 Jan 2000 00:00:00} {Mon, 03 Jan 2000 00:00:00} {Tue, 04 Jan 2000 00:00:00} {Wed, 05 Jan 2000 00:00:00} {Thu, 06 Jan 2000 00:00:00} {Fri, 07 Jan 2000 00:00:00}
} -result [list \
0 946684800 0 946771200 0 946857600 0 946944000 0 947030400 0 947116800 0 947203200 \
0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 0 947246400 \
0 946641600 0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 \
]
test clock-46.16-pos-fmt1 {
scan with format: validation rules: valid day of week (must work for all weekdays)
} -constraints notclassic -body {
_invalid_test {:GMT -12:00 +12:00} {-format "%a, %d %b %Y %H:%M:%S"} {Sat, 01 Jan 2000 00:00:00} {Sun, 02 Jan 2000 00:00:00} {Mon, 03 Jan 2000 00:00:00} {Tue, 04 Jan 2000 00:00:00} {Wed, 05 Jan 2000 00:00:00} {Thu, 06 Jan 2000 00:00:00} {Fri, 07 Jan 2000 00:00:00}
} -result [list \
0 946684800 0 946771200 0 946857600 0 946944000 0 947030400 0 947116800 0 947203200 \
0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 0 947246400 \
0 946641600 0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 \
]
test clock-46.16-pos-fmt2 {
scan with format: validation rules: valid day of week (must work for all weekdays)
} -constraints notclassic -body {
_invalid_test {:GMT -12:00 +12:00} {-format "%u, %d %b %Y %H:%M:%S"} {6, 01 Jan 2000 00:00:00} {7, 02 Jan 2000 00:00:00} {1, 03 Jan 2000 00:00:00} {2, 04 Jan 2000 00:00:00} {3, 05 Jan 2000 00:00:00} {4, 06 Jan 2000 00:00:00} {5, 07 Jan 2000 00:00:00}
} -result [list \
0 946684800 0 946771200 0 946857600 0 946944000 0 947030400 0 947116800 0 947203200 \
0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 0 947246400 \
0 946641600 0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 \
]
test clock-46.16-pos-fmt3 {
scan with format: validation rules: valid day of week (must work for all weekdays)
} -constraints notclassic -body {
_invalid_test {:GMT -12:00 +12:00} {-format "%w, %d %b %Y %H:%M:%S"} {6, 01 Jan 2000 00:00:00} {0, 02 Jan 2000 00:00:00} {1, 03 Jan 2000 00:00:00} {2, 04 Jan 2000 00:00:00} {3, 05 Jan 2000 00:00:00} {4, 06 Jan 2000 00:00:00} {5, 07 Jan 2000 00:00:00}
} -result [list \
0 946684800 0 946771200 0 946857600 0 946944000 0 947030400 0 947116800 0 947203200 \
0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 0 947246400 \
0 946641600 0 946728000 0 946814400 0 946900800 0 946987200 0 947073600 0 947160000 \
]
rename _invalid_test {}
|
| ︙ | ︙ | |||
37286 37287 37288 37289 37290 37291 37292 |
{":America/New_York"
"2017-03-12 01:59:59" "2017-03-12 02:00:00" "2017-03-12 02:59:59" "2017-03-12 03:00:00"
"2017-11-05 01:59:59" "2017-11-05 02:00:00"}
{":America/New_York"
"2018-03-11 01:59:59" "2018-03-11 02:00:00" "2018-03-11 02:59:59" "2018-03-11 03:00:00"
"2018-11-04 01:59:59" "2018-11-04 02:00:00"}
}
| > | | | 37325 37326 37327 37328 37329 37330 37331 37332 37333 37334 37335 37336 37337 37338 37339 37340 37341 |
{":America/New_York"
"2017-03-12 01:59:59" "2017-03-12 02:00:00" "2017-03-12 02:59:59" "2017-03-12 03:00:00"
"2017-11-05 01:59:59" "2017-11-05 02:00:00"}
{":America/New_York"
"2018-03-11 01:59:59" "2018-03-11 02:00:00" "2018-03-11 02:59:59" "2018-03-11 03:00:00"
"2018-11-04 01:59:59" "2018-11-04 02:00:00"}
}
test clock-46.19-1 {
free-scan: validation rules: invalid time (DST-hole, out of range in time-zone)
} -constraints notclassic -body {
set res {}
foreach tz $dst_hole_check { set dt [lassign $tz tz]; foreach dt $dt {
lappend res [set v [catch {clock scan $dt -timezone $tz -valid 1} msg]]
if {$v} { lappend res $msg }
}}
set res
} -cleanup {
|
| ︙ | ︙ | |||
37309 37310 37311 37312 37313 37314 37315 |
foreach tz $dst_hole_check { set dt [lassign $tz tz]; foreach dt $dt {
lappend res [set v [catch {clock scan $dt -timezone $tz} msg]]
}}
set res
} -cleanup {
unset -nocomplain res v dt tz
} -result [lrepeat 4 {*}[if {$valid_mode} {list 0 1 1 0 0 0} else {list 0 0 0 0 0 0}]]
| > | | | 37349 37350 37351 37352 37353 37354 37355 37356 37357 37358 37359 37360 37361 37362 37363 37364 37365 |
foreach tz $dst_hole_check { set dt [lassign $tz tz]; foreach dt $dt {
lappend res [set v [catch {clock scan $dt -timezone $tz} msg]]
}}
set res
} -cleanup {
unset -nocomplain res v dt tz
} -result [lrepeat 4 {*}[if {$valid_mode} {list 0 1 1 0 0 0} else {list 0 0 0 0 0 0}]]
test clock-46.19-3 {
scan: validation rules: invalid time (DST-hole, out of range in time-zone)
} -constraints notclassic -body {
set res {}
foreach tz $dst_hole_check { set dt [lassign $tz tz]; foreach dt $dt {
lappend res [set v [catch {clock scan $dt -timezone $tz -format "%Y-%m-%d %H:%M:%S" -valid 1} msg]]
if {$v} { lappend res $msg }
}}
set res
} -cleanup {
|
| ︙ | ︙ | |||
37351 37352 37353 37354 37355 37356 37357 |
lappend res [catch {clock scan $v -format $fmt -valid 1 -timezone $tz} msg] $msg
}
}
}
set res
}
test clock-46.20 {scan: validation rules: invalid time} \
| | | | | | | | | | | | > | > > | > | 37392 37393 37394 37395 37396 37397 37398 37399 37400 37401 37402 37403 37404 37405 37406 37407 37408 37409 37410 37411 37412 37413 37414 37415 37416 37417 37418 37419 37420 37421 37422 37423 37424 37425 37426 37427 37428 37429 37430 37431 37432 37433 37434 37435 37436 37437 37438 37439 37440 37441 37442 37443 37444 37445 37446 37447 37448 37449 37450 37451 37452 37453 37454 37455 37456 37457 37458 37459 37460 37461 37462 37463 37464 37465 37466 37467 37468 37469 |
lappend res [catch {clock scan $v -format $fmt -valid 1 -timezone $tz} msg] $msg
}
}
}
set res
}
test clock-46.20 {scan: validation rules: invalid time} \
-constraints notclassic -body {
# 13:00 am/pm are invalid input strings...
_invalid_test "13:00 am" "%H:%M %p" "13:00 pm" "%H:%M %p"
} -result [lrepeat 10 1 {unable to convert input string: invalid time (hour)}]
test clock-46.21 {scan: validation rules: invalid time} \
-constraints notclassic -body {
# invalid minutes in input strings...
_invalid_test "23:70" "%H:%M" "11:80 pm" "%H:%M %p"
} -result [lrepeat 10 1 {unable to convert input string: invalid time (minutes)}]
test clock-46.22 {scan: validation rules: invalid time} \
-constraints notclassic -body {
# invalid seconds in input strings...
_invalid_test "23:00:70" "%H:%M:%S" "11:00:80 pm" "%H:%M:%S %p"
} -result [lrepeat 10 1 {unable to convert input string: invalid time}]
test clock-46.23 {scan: validation rules: invalid day} \
-constraints notclassic -body {
_invalid_test "29 Feb 2017" "%d %b %Y" "30 Feb 2016" "%d %b %Y"
} -result [lrepeat 10 1 {unable to convert input string: invalid day}]
test clock-46.24 {scan: validation rules: invalid day} \
-constraints notclassic -body {
_invalid_test "0 Feb 2017" "%d %b %Y" "00 Feb 2017" "%d %b %Y"
} -result [lrepeat 10 1 {unable to convert input string: invalid day}]
test clock-46.25 {scan: validation rules: invalid month} \
-constraints notclassic -body {
_invalid_test "13/13/2017" "%m/%d/%Y" "00/01/2017" "%m/%d/%Y"
} -result [lrepeat 10 1 {unable to convert input string: invalid month}]
test clock-46.26 {scan: validation rules: ambiguous day} \
-constraints notclassic -body {
_invalid_test "1970-01-02--004" "%Y-%m-%d--%j" "70-01-02--004" "%y-%m-%d--%j"
} -result [lrepeat 10 1 {unable to convert input string: ambiguous day}]
test clock-46.27 {scan: validation rules: ambiguous year} \
-constraints notclassic -body {
_invalid_test "19700106 00W014" "%Y%m%d %gW%V%u" "1970006 00W014" "%Y%j %gW%V%u"
} -result [lrepeat 10 1 {unable to convert input string: ambiguous year}]
test clock-46.28 {scan: validation rules: invalid day of week} \
-constraints notclassic -body {
_invalid_test "Sat Jan 02 00:00:00 1970" "%a %b %d %H:%M:%S %Y"
} -result [lrepeat 5 1 {unable to convert input string: invalid day of week}]
test clock-46.29-1 {scan: validation rules: invalid day of year} \
-constraints notclassic -body {
_invalid_test "000-2017" "%j-%Y" "366-2017" "%j-%Y" "000-2017" "%j-%G" "366-2017" "%j-%G"
} -result [lrepeat 20 1 {unable to convert input string: invalid day of year}]
test clock-46.29-2 {scan: validation rules: valid day of leap/not leap year} \
-constraints notclassic -body {
list [clock format [clock scan "366-2016" -format "%j-%Y" -valid 1 -gmt 1] -format "%d-%m-%Y" -gmt 1] \
[clock format [clock scan "365-2017" -format "%j-%Y" -valid 1 -gmt 1] -format "%d-%m-%Y" -gmt 1] \
[clock format [clock scan "366-2016" -format "%j-%G" -valid 1 -gmt 1] -format "%d-%m-%Y" -gmt 1] \
[clock format [clock scan "365-2017" -format "%j-%G" -valid 1 -gmt 1] -format "%d-%m-%Y" -gmt 1]
} -result {31-12-2016 31-12-2017 31-12-2016 31-12-2017}
test clock-46.30 {
scan: validation rules: invalid year
} -constraints notclassic -setup {
set orgcfg [list -min-year [::tcl::unsupported::clock::configure -min-year] -max-year [::tcl::unsupported::clock::configure -max-year] \
-year-century [::tcl::unsupported::clock::configure -year-century] -century-switch [::tcl::unsupported::clock::configure -century-switch]]
::tcl::unsupported::clock::configure -min-year 2000 -max-year 2100 -year-century 2000 -century-switch 38
} -body {
_invalid_test "01-01-70" "%d-%m-%y" "01-01-1870" "%d-%m-%C%y" "01-01-1970" "%d-%m-%Y"
} -result [lrepeat 15 1 {unable to convert input string: invalid year}] -cleanup {
::tcl::unsupported::clock::configure {*}$orgcfg
unset -nocomplain orgcfg
}
test clock-46.31 {
scan: validation rules: invalid iso year
} -constraints notclassic -setup {
set orgcfg [list -min-year [::tcl::unsupported::clock::configure -min-year] -max-year [::tcl::unsupported::clock::configure -max-year] \
-year-century [::tcl::unsupported::clock::configure -year-century] -century-switch [::tcl::unsupported::clock::configure -century-switch]]
::tcl::unsupported::clock::configure -min-year 2000 -max-year 2100 -year-century 2000 -century-switch 38
} -body {
_invalid_test "01-01-70" "%d-%m-%g" "01-01-9870" "%d-%m-%C%g" "01-01-9870" "%d-%m-%G"
} -result [lrepeat 15 1 {unable to convert input string: invalid iso year}] -cleanup {
::tcl::unsupported::clock::configure {*}$orgcfg
|
| ︙ | ︙ | |||
37454 37455 37456 37457 37458 37459 37460 |
-match regexp \
-result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}}
test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \
-constraints win \
-setup {
# override the registry so that the test takes place in New York time
| | | | | | | | | | | | 37499 37500 37501 37502 37503 37504 37505 37506 37507 37508 37509 37510 37511 37512 37513 37514 37515 37516 37517 37518 37519 37520 37521 37522 37523 37524 37525 37526 37527 37528 37529 37530 37531 37532 37533 37534 37535 37536 37537 37538 37539 37540 37541 37542 37543 37544 37545 37546 37547 37548 37549 37550 37551 37552 37553 |
-match regexp \
-result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}}
test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \
-constraints win \
-setup {
# override the registry so that the test takes place in New York time
namespace eval ${clockns} {
namespace import -force ::testClock::registry
}
set noreg [info exists ${clockns}::NoRegistry]
if {$noreg} {unset ${clockns}::NoRegistry}
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
unset env(TZ)
}
if { [info exists env(TCL_TZ)] } {
set oldTclTZ $env(TCL_TZ)
unset env(TCL_TZ)
}
# make it so New York time is a missing file
dict set ${clockns}::WinZoneInfo \
{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} \
:No/Such/File
${clockns}::ClearCaches
} \
-body {
list [${clockns}::GuessWindowsTimeZone] \
[clock format 0 -locale system -format "%H:%M:%S %Z"] \
[clock format -86400 -format "%Y"]
} \
-cleanup {
# restore the registry and environment
namespace eval ${clockns} {
rename registry {}
}
if {$noreg} {set ${clockns}::NoRegistry {}}
if { [info exists oldTclTZ] } {
set env(TCL_TZ) $oldTclTZ
}
if { [info exists oldTZ] } {
set env(TZ) $oldTZ
}
# put New York back on the map
dict set ${clockns}::WinZoneInfo \
{-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} \
:America/New_York
${clockns}::ClearCaches
} \
-result {<-0500>+05:00:00<-0400>+04:00:00,M3.2.0/02:00:00,M11.1.0/02:00:00 {19:00:00 -0500} 1969}
test clock-50.1 {format / scan -1 as a local time} {
if {[catch {
clock scan \
[clock format -1 -format %Y%m%d%H%M%S -timezone :localtime] \
|
| ︙ | ︙ | |||
37664 37665 37666 37667 37668 37669 37670 | 0xd0 0x81 0x1a 0x1c 0xfa 0xf8 0x75 0x10 0xfb 0xe8 0x58 0x00 0x00 0x01 0x00 0x01 0x02 0x01 0x02 0x01 0x00 0x01 0xff 0xff 0xab 0xa0 0x01 0x00 0xff 0xff 0x9d 0x90 0x00 0x04 0xff 0xff 0xab 0xa0 0x01 0x08 0x4d 0x44 0x54 0x00 0x4d 0x53 0x54 0x00 0x4d 0x57 0x54 0x00 0x00 0x00 0x00 0x00 0x00 0x00 }] close $f | | | | | | | | 37709 37710 37711 37712 37713 37714 37715 37716 37717 37718 37719 37720 37721 37722 37723 37724 37725 37726 37727 37728 37729 37730 |
0xd0 0x81 0x1a 0x1c 0xfa 0xf8 0x75 0x10 0xfb 0xe8 0x58 0x00
0x00 0x01 0x00 0x01 0x02 0x01 0x02 0x01 0x00 0x01 0xff 0xff
0xab 0xa0 0x01 0x00 0xff 0xff 0x9d 0x90 0x00 0x04 0xff 0xff
0xab 0xa0 0x01 0x08 0x4d 0x44 0x54 0x00 0x4d 0x53 0x54 0x00
0x4d 0x57 0x54 0x00 0x00 0x00 0x00 0x00 0x00 0x00
}]
close $f
set ${clockns}::ZoneinfoPaths \
[linsert [set ${clockns}::ZoneinfoPaths] 0 $tzdir]
${clockns}::ClearCaches
}
-cleanup {
set ${clockns}::ZoneinfoPaths \
[lrange [set ${clockns}::ZoneinfoPaths] 1 end]
${clockns}::ClearCaches
removeFile PhoenixOne $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
}
-body {
clock format 1072940400 -timezone :Test/PhoenixOne \
-format {%Y-%m-%d %H:%M:%S %Z}
|
| ︙ | ︙ | |||
37721 37722 37723 37724 37725 37726 37727 | 0xee 0x00 0x00 0xff 0xff 0xab 0xa0 0x01 0x04 0xff 0xff 0x9d 0x90 0x00 0x08 0xff 0xff 0xab 0xa0 0x01 0x0c 0x4c 0x4d 0x54 0x00 0x4d 0x44 0x54 0x00 0x4d 0x53 0x54 0x00 0x4d 0x57 0x54 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x0a 0x4d 0x53 0x54 0x37 0x0a }] close $f | | | | | | | | 37766 37767 37768 37769 37770 37771 37772 37773 37774 37775 37776 37777 37778 37779 37780 37781 37782 37783 37784 37785 37786 37787 |
0xee 0x00 0x00 0xff 0xff 0xab 0xa0 0x01 0x04 0xff 0xff 0x9d
0x90 0x00 0x08 0xff 0xff 0xab 0xa0 0x01 0x0c 0x4c 0x4d 0x54
0x00 0x4d 0x44 0x54 0x00 0x4d 0x53 0x54 0x00 0x4d 0x57 0x54
0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x0a 0x4d 0x53
0x54 0x37 0x0a
}]
close $f
set ${clockns}::ZoneinfoPaths \
[linsert [set ${clockns}::ZoneinfoPaths] 0 $tzdir]
${clockns}::ClearCaches
}
-cleanup {
set ${clockns}::ZoneinfoPaths \
[lrange [set ${clockns}::ZoneinfoPaths] 1 end]
${clockns}::ClearCaches
removeFile PhoenixTwo $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
}
-body {
clock format 1072940400 -timezone :Test/PhoenixTwo \
-format {%Y-%m-%d %H:%M:%S %Z}
|
| ︙ | ︙ | |||
37931 37932 37933 37934 37935 37936 37937 |
0x54 0x00 0x50 0x53 0x54 0x00 0x50 0x44 0x54 0x00 0x50 0x57 0x54
0x00 0x50 0x50 0x54 0x00 0x00 0x00 0x00 0x00 0x00 0x01 0x00 0x00
0x00 0x00 0x00 0x01 0x0a 0x50 0x53 0x54 0x38 0x50 0x44 0x54 0x2c
0x4d 0x34 0x2e 0x31 0x2e 0x30 0x2c 0x4d 0x31 0x30 0x2e 0x35 0x2e
0x30 0x0a
}]
close $f
| | | | | | | | | 37976 37977 37978 37979 37980 37981 37982 37983 37984 37985 37986 37987 37988 37989 37990 37991 37992 37993 37994 37995 37996 37997 37998 37999 38000 38001 38002 38003 38004 38005 38006 38007 38008 38009 38010 |
0x54 0x00 0x50 0x53 0x54 0x00 0x50 0x44 0x54 0x00 0x50 0x57 0x54
0x00 0x50 0x50 0x54 0x00 0x00 0x00 0x00 0x00 0x00 0x01 0x00 0x00
0x00 0x00 0x00 0x01 0x0a 0x50 0x53 0x54 0x38 0x50 0x44 0x54 0x2c
0x4d 0x34 0x2e 0x31 0x2e 0x30 0x2c 0x4d 0x31 0x30 0x2e 0x35 0x2e
0x30 0x0a
}]
close $f
set ${clockns}::ZoneinfoPaths \
[linsert [set ${clockns}::ZoneinfoPaths] 0 $tzdir]
${clockns}::ClearCaches
}
-cleanup {
set ${clockns}::ZoneinfoPaths \
[lrange [set ${clockns}::ZoneinfoPaths] 1 end]
${clockns}::ClearCaches
removeFile TijuanaTwo $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
}
-body {
clock format 2224738800 -timezone :Test/TijuanaTwo \
-format {%Y-%m-%d %H:%M:%S %Z}
}
-result {2040-07-01 00:00:00 PDT}
}
test clock-56.4 {Bug 3470928} {*}{
-constraints notclassic -setup {
clock format [clock seconds]
set tzdir [makeDirectory zoneinfo]
set tzdir2 [makeDirectory Test $tzdir]
set tzfile [makeFile {} Windhoek $tzdir2]
set f [open $tzfile wb]
puts -nonewline $f [binary format c* {
0x54 0x5a 0x69 0x66 0x32 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
|
| ︙ | ︙ | |||
38080 38081 38082 38083 38084 38085 38086 |
0x4d 0x54 0x00 0x53 0x57 0x41 0x54 0x00 0x53 0x41 0x53 0x54 0x00
0x43 0x41 0x54 0x00 0x57 0x41 0x53 0x54 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x0a 0x57 0x41
0x54 0x2d 0x31 0x57 0x41 0x53 0x54 0x2c 0x4d 0x39 0x2e 0x31 0x2e
0x30 0x2c 0x4d 0x34 0x2e 0x31 0x2e 0x30 0x0a
}]
close $f
| | | | | | | | 38125 38126 38127 38128 38129 38130 38131 38132 38133 38134 38135 38136 38137 38138 38139 38140 38141 38142 38143 38144 38145 38146 38147 38148 38149 |
0x4d 0x54 0x00 0x53 0x57 0x41 0x54 0x00 0x53 0x41 0x53 0x54 0x00
0x43 0x41 0x54 0x00 0x57 0x41 0x53 0x54 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x0a 0x57 0x41
0x54 0x2d 0x31 0x57 0x41 0x53 0x54 0x2c 0x4d 0x39 0x2e 0x31 0x2e
0x30 0x2c 0x4d 0x34 0x2e 0x31 0x2e 0x30 0x0a
}]
close $f
set ${clockns}::ZoneinfoPaths \
[linsert [set ${clockns}::ZoneinfoPaths] 0 $tzdir]
${clockns}::ClearCaches
}
-body {
clock format 1326054606 -timezone :Test/Windhoek
}
-cleanup {
set ${clockns}::ZoneinfoPaths \
[lrange [set ${clockns}::ZoneinfoPaths] 1 end]
${clockns}::ClearCaches
removeFile Windhoek $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
}
-result {Sun Jan 08 22:30:06 WAST 2012}
}
|
| ︙ | ︙ | |||
38257 38258 38259 38260 38261 38262 38263 |
clock scan "1 December 2000" -gmt true -format "%d %b %Y"
} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-60.12 {case insensitive month names} {
clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y"
} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-61.1 {overflow of a wide integer on output} {*}{
| | | | | > | > > | > > | > > | > | | | 38302 38303 38304 38305 38306 38307 38308 38309 38310 38311 38312 38313 38314 38315 38316 38317 38318 38319 38320 38321 38322 38323 38324 38325 38326 38327 38328 38329 38330 38331 38332 38333 38334 38335 38336 38337 38338 38339 38340 38341 38342 38343 38344 38345 38346 38347 38348 38349 38350 38351 38352 38353 38354 38355 38356 38357 38358 38359 38360 38361 38362 38363 38364 38365 38366 38367 38368 38369 38370 38371 38372 38373 38374 38375 38376 38377 38378 38379 38380 38381 38382 38383 38384 38385 38386 |
clock scan "1 December 2000" -gmt true -format "%d %b %Y"
} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-60.12 {case insensitive month names} {
clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y"
} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-61.1 {overflow of a wide integer on output} {*}{
-constraints notclassic -body {
clock format 0x8000000000000000 -format %s -gmt true
}
-result {integer value too large to represent}
-errorCode {CLOCK badOption 0x8000000000000000}
-returnCodes error
}
test clock-61.1b {overflow of a wide integer on base} {*}{
-constraints notclassic -body {
clock scan "" -base 0x8000000000000000 -gmt true
}
-result {integer value too large to represent}
-errorCode {CLOCK badOption 0x8000000000000000}
-returnCodes error
}
test clock-61.2 {overflow of a wide integer on output} {*}{
-constraints notclassic -body {
clock format -0x8000000000000001 -format %s -gmt true
}
-result {integer value too large to represent}
-errorCode {CLOCK badOption -0x8000000000000001}
-returnCodes error
}
test clock-61.2b {overflow of a wide integer on base} {*}{
-constraints notclassic -body {
clock scan "" -base -0x8000000000000001 -gmt true
}
-result {integer value too large to represent}
-errorCode {CLOCK badOption -0x8000000000000001}
-returnCodes error
}
test clock-61.3 {
near-miss overflow of a wide integer on output, very large datetime (upper range)
} notclassic {
clock format 0x00F0000000000000 -format "%s %Y %EE" -gmt true
} [list [expr 0x00F0000000000000] 2140702833 C.E.]
test clock-61.4 {
near-miss overflow of a wide integer on output, very small datetime (lower range)
} notclassic {
clock format -0x00F0000000000000 -format "%s %Y %EE" -gmt true
} [list [expr -0x00F0000000000000] 2140654939 B.C.E.]
test clock-61.5 {
overflow of possible date-time (upper range)
} -constraints notclassic -body {
clock format 0x00F0000000000001 -gmt true
} -returnCodes error -result {integer value too large to represent} -errorCode {CLOCK badOption 0x00F0000000000001}
test clock-61.6 {
overflow of possible date-time (lower range)
} -constraints notclassic -body {
clock format -0x00F0000000000001 -gmt true
} -returnCodes error -result {integer value too large to represent} -errorCode {CLOCK badOption -0x00F0000000000001}
test clock-62.1 {Bug 1902423} {*}{
-setup {${clockns}::ClearCaches}
-body {
set s 1204049747
set f1 [clock format $s -format {%Y-%m-%d %T} -locale C]
set f2 [clock format $s -format {%Y-%m-%d %H:%M:%S} -locale C]
if {$f1 ne $f2} {
subst "$f2 is not $f1"
} else {
subst "ok"
}
}
-result ok
}
test clock-63.1 {Incorrect use of internal ConvertLocalToUTC command} {*}{
-body {
${clockns}::ConvertLocalToUTC {immaterial stuff} {} 12345
}
-returnCodes error
-result {key "localseconds" not found in dictionary}
}
test clock-64.1 {:: in format string [Bug 2362156]} {*}{
-body {
|
| ︙ | ︙ | |||
38358 38359 38360 38361 38362 38363 38364 |
-match glob
-returnCodes error
-result {cannot use -gmt and -timezone in same call}
}
test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
-setup {
| | | | | 38411 38412 38413 38414 38415 38416 38417 38418 38419 38420 38421 38422 38423 38424 38425 38426 38427 38428 38429 38430 38431 38432 38433 38434 38435 38436 38437 38438 38439 38440 38441 38442 38443 38444 38445 38446 |
-match glob
-returnCodes error
-result {cannot use -gmt and -timezone in same call}
}
test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
-setup {
${clockns}::ClearCaches
}
-body {
clock scan 1200 \
-timezone {<EST>+05:00:00<EDT>+04:00:00,M3.2.0/02:00:00,M11.1.0/02:00:00} \
-base 1256529600 \
-format %H%M
}
-result 1256572800
}
test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
clock format [clock seconds] -format %%r
} %r
test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
${clockns}::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.3 {Bug d19a30db57} -body {
# error, not segfault
${clockns}::GetJulianDayFromEraYearWeekDay {} 2361222
} -returnCodes error -match glob -result *
test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup {
package require msgcat
set current [msgcat::mclocale]
} -body {
msgcat::mclocale de_de
set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]]
|
| ︙ | ︙ | |||
38405 38406 38407 38408 38409 38410 38411 38412 38413 |
msgcat::mclocale en_uk
# This will fail without the bug fix, as still de_de is active
expr {$res == [clock scan "01/01/1970" -locale current -format %x -gmt 1]}
} -cleanup {
msgcat::mclocale $current
} -result {1}
# cleanup
| > > | | 38458 38459 38460 38461 38462 38463 38464 38465 38466 38467 38468 38469 38470 38471 38472 38473 38474 38475 38476 |
msgcat::mclocale en_uk
# This will fail without the bug fix, as still de_de is active
expr {$res == [clock scan "01/01/1970" -locale current -format %x -gmt 1]}
} -cleanup {
msgcat::mclocale $current
} -result {1}
# END TESTS MARKER
# cleanup
${clockns}::ClearCaches
rename test {}
namespace import -force ::tcltest::*
# adjust expected skipped (valid_off is an artificial constraint):
if {$valid_mode && [info exists ::tcltest::skippedBecause(valid_off)]} {
incr ::tcltest::numTests(Total) -$::tcltest::skippedBecause(valid_off)
incr ::tcltest::numTests(Skipped) -$::tcltest::skippedBecause(valid_off)
unset ::tcltest::skippedBecause(valid_off)
|
| ︙ | ︙ |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Copyright © 2004 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Copyright © 2024 Nathan Coulter.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# clockClassic.test --
#
# This test file covers the 'clock' command that manipulates time.
#
# 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.
namespace eval ::tcl::clockclassic::test {}
apply {{} {
global env
global errorCode
set chan [open [file join [file dirname [
file normalize [info script]]] clock.test]]
try {
set clocktestscript [read $chan]
} finally {
close $chan
}
set status [regexp {\n# START TESTS MARKER\n(.*)\n# END TESTS MARKER\n} \
$clocktestscript -> clocktestscript]
if {!$status} {
error [list {could not extract tests from clock.test}]
}
namespace import ::tcl::clock::classic
rename [namespace current]::classic [namespace current]::clock
set clockns [namespace ensemble configure clock -namespace]
set valid_mode 0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
package require registry
}]} {
namespace eval $clockns {variable NoRegistry {}}
}
}
package require msgcat 1.4
testConstraint notclassic 0
testConstraint valid_off 1
testConstraint detroit \
[expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}]
testConstraint y2038 \
[expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]
# Note that all code between comments '# BEGIN' and '# END' is
# autogenerated by 'tools/makeTestCases.tcl'. DO NOT EDIT CODE BETWEEN
# '# BEGIN' and '# END'.
# Define a fictitious locale, 'en_US_roman', for formatting of clock
# strings with localized numerics and eras. This locale will be used
# in testing the 'clock' command.
namespace eval $clockns {
::msgcat::mcmset en_US_roman {
LOCALE_ERAS {
{-62164627200 {} 0}
{-59008867200 c 100}
{-55853107200 cc 200}
{-52697347200 ccc 300}
{-49541587200 cd 400}
{-46385827200 d 500}
{-43230067200 dc 600}
{-40074307200 dcc 700}
{-36918547200 dccc 800}
{-33762787200 cm 900}
{-30607027200 m 1000}
{-27451267200 mc 1100}
{-24295507200 mcc 1200}
{-21139747200 mccc 1300}
{-17983987200 mcd 1400}
{-14828227200 md 1500}
{-11672467200 mdc 1600}
{-8516707200 mdcc 1700}
{-5364662400 mdccc 1800}
{-2208988800 mcm 1900}
{946684800 mm 2000}
}
LOCALE_NUMERALS {
? i ii iii iv v vi vii viii ix
x xi xii xiii xiv xv xvi xvii xviii xix
xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
l li lii liii liv lv lvi lvii lviii lix
lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii
lxxxix
xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
c
}
DATE_FORMAT {%m/%d/%Y}
TIME_FORMAT {%H:%M:%S}
DATE_TIME_FORMAT {%x %X}
LOCALE_DATE_FORMAT {die %Od mensis %Om annoque %EY}
LOCALE_TIME_FORMAT {%OH h %OM m %OS s}
LOCALE_DATE_TIME_FORMAT {%Ex %EX}
BCE {Before Christ}
CE {Anno Domini}
}
}
#----------------------------------------------------------------------
#
# The tests for the Windows platform are careful *not* to muck with
# the system registry. Instead, the 'registry' command is overridden
# in the $clockns namespace.
#
#----------------------------------------------------------------------
namespace eval ::testClock {
namespace export registry
set reg \
[dict create \
HKEY_CURRENT_USER\\Control\ Panel\\International \
[dict create \
locale 0409 \
sShortDate dd-MMM-yyyy \
sLongDate "'the' dd''' day of' MMMM yyyy" \
sTimeFormat "h:mm:ss tt"] \
HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation \
[dict create \
Bias 300 \
StandardBias 0 \
DaylightBias -60 \
StandardStart \x00\x00\x0B\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \
DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]]
}
proc ::testClock::registry { cmd path key } {
variable reg
if { $cmd ne {get} } {
return -code error "test case attempts to write/query the registry"
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
test clock-1.1 "clock format - bad time" {
list [catch {clock format foo} msg] $msg
} {1 {expected integer but got "foo"}}
test clock-1.4 "clock format - bad flag" {*}{
-body {
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
}
-match glob
-result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}
# Test input conversions.
test clock-6.10 {input of seconds - overflow} {
list [catch {clock scan 9223372036854775808 -format %s -gmt true} result opt] $result [dict getd $opt -errorcode ""]
} {1 {integer value too large to represent} {CLOCK dateTooLarge}}
test clock-6.10c {input of seconds - overflow ??, bug [1f40aa83c5]} knownBug {
clock scan 27670116110564327423 -gmt true
} 89170590268800
test clock-6.10d {input of seconds - overflow ??, bug [1f40aa83c5]} knownBug {
clock scan 27670116110564327424 -gmt true
} -90247104115200
try $clocktestscript
test clock-9.2 {Julian day takes precedence over ccyymmdd} {
clock scan {2440588 20000101} -format {%J %Y%m%d} -gmt true
} 0
# BEGIN testcases11
# Test precedence among yyyymmdd and yyyyddd
test clock-11.1 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700101002 -format %Y%m%d%j -gmt 1
} 86400
test clock-11.2 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197001002 -format %m%Y%d%j -gmt 1
} 86400
test clock-11.3 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197001002 -format %d%Y%m%j -gmt 1
} 86400
test clock-11.4 {precedence of ccyyddd and ccyymmdd} {
clock scan 00219700101 -format %j%Y%m%d -gmt 1
} 0
# END testcases11
# Legacy tests
# clock clicks
# clock scan
test clock-34.1 {clock scan tests} {
list [catch {clock scan} msg] $msg
} {1 {wrong # args: should be "clock scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"}}
test clock-34.9 {clock scan tests} {
list [catch {clock scan "Jan 12" -bad arg} msg] $msg
} {1 {bad option "-bad": must be -base, -format, -gmt, -locale, or -timezone}}
# The following two two tests test the two year date policy
test {clock-34.12 nogmt} {clock scan, relative times} {
set time [clock scan "Oct 23, 1992 -1 day"]
clock format $time -format {%b %d, %Y}
} "Oct 22, 1992"
test {clock-34.13 nogmt} {clock scan, ISO 8601 base date format} {
set time [clock scan "19921023"]
clock format $time -format {%b %d, %Y}
} "Oct 23, 1992"
test {clock-34.14 nogmt} {clock scan, ISO 8601 expanded date format} {
set time [clock scan "1992-10-23"]
clock format $time -format {%b %d, %Y}
} "Oct 23, 1992"
test {clock-34.15 nogmt} {clock scan, DD-Mon-YYYY format} {
set time [clock scan "23-Oct-1992"]
clock format $time -format {%b %d, %Y}
} "Oct 23, 1992"
test {clock-34.16 nogmt} {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023T235959"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 23:59:59"
test {clock-34.17 nogmt} {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023 235959"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 23:59:59"
test {clock-34.18 nogmt} {clock scan, ISO 8601 point in time format} {
set time [clock scan "19921023T000000"]
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
# CLOCK SCAN REAL TESTS
# We use 5am PST, 31-12-1999 as the base for these scans because irrespective
# of your local timezone it should always give us times on December 31, 1999
set 5amPST 946645200
test clock-34.19 {clock scan, number meridian} {
set t1 [clock scan "5 am" -base $5amPST -gmt true]
set t2 [clock scan "5 pm" -base $5amPST -gmt true]
set t3 [clock scan "5 a.m." -base $5amPST -gmt true]
set t4 [clock scan "5 p.m." -base $5amPST -gmt true]
list \
[clock format $t1 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t2 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t3 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t4 -format {%b %d, %Y %H:%M:%S} -gmt true]
} [list "Dec 31, 1999 05:00:00" "Dec 31, 1999 17:00:00" \
"Dec 31, 1999 05:00:00" "Dec 31, 1999 17:00:00"]
test clock-34.20 {clock scan, number:number meridian} {
clock format [clock scan "5:30 pm" -base $5amPST -gmt true] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 17:30:00"
# weekday specification and base.
# clock seconds
test clock-37.1 {%s gmt testing} {
set s [clock seconds]
set a [clock format $s -format %s -gmt 0]
set b [clock format $s -format %s -gmt 1]
# %s, being the difference between local and Greenwich, does not
# depend on the time zone.
set c [expr {$b-$a}]
} {0}
test clock-45.1 {regression test - time zone containing only two digits} \
-body {
clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z
} \
-result 482134530
# case-insensitive matching of weekday and month names [Bug 1781282]
test clock-61.1 {overflow of a wide integer on output} {*}{
-body {
clock format 0x8000000000000000 -format %s -gmt true
}
-result {integer value too large to represent}
-returnCodes error
}
test clock-61.2 {overflow of a wide integer on output} {*}{
-body {
clock format -0x8000000000000001 -format %s -gmt true
}
-result {integer value too large to represent}
-returnCodes error
}
test clock-61.3 {near-miss overflow of a wide integer on output} {
clock format 0x7fffffffffffffff -format %s -gmt true
} [expr {0x7fffffffffffffff}]
test clock-61.4 {near-miss overflow of a wide integer on output} {
clock format -0x8000000000000000 -format %s -gmt true
} [expr {-0x8000000000000000}]
# cleanup
namespace delete ::testClock
${clockns}::ClearCaches
::tcltest::cleanupTests
return
#apply
} ::tcl::clockclassic::test}
# Local Variables:
# mode: tcl
# End:
|
|
| < < < < < < > > > > > > > > > > > > > > | 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 © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The file tests the tclCmdAH.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
}]
testConstraint filetime64bit [expr {
[testConstraint time64bit] && (
![testConstraint unix] || [apply {{} {
# check whether disk may have 2038 problem, see [fd91b0ca09cb171f]:
set fn [makeFile "" foo.text]
if {[catch {
| | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
}]
testConstraint filetime64bit [expr {
[testConstraint time64bit] && (
![testConstraint unix] || [apply {{} {
# check whether disk may have 2038 problem, see [fd91b0ca09cb171f]:
set fn [makeFile "" foo.text]
if {[catch {
exec sh -c "TZ=:UTC LC_TYME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TYME=en_US ls -l '$fn'"
} res]} {
#puts "Check constraint failed:\t$res"
set res {}
}
removeFile $fn
regexp {\mJun\s+29\s+2070\M} $res
}}]
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
set system [encoding system]
} -body {
encoding system iso8859-1
encoding system
} -cleanup {
encoding system $system
} -result iso8859-1
| < | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
set system [encoding system]
} -body {
encoding system iso8859-1
encoding system
} -cleanup {
encoding system $system
} -result iso8859-1
#
# encoding convertfrom 4.3.*
# Odd number of args is always invalid since last two args
# are ENCODING DATA and all options take a value
badnumargs cmdAH-4.3.1 {encoding convertfrom} {}
badnumargs cmdAH-4.3.2 {encoding convertfrom} {-failindex VAR ABC}
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the file
# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # Commands covered: none # # This file contains a collection of tests for Tcl_GetCommandInfo, # Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and # Tcl_NameOfCommand. 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for Tcl_GetCommandInfo,
# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and
# Tcl_NameOfCommand. Sourcing this file into Tcl runs the tests
# and generates output for errors. No output means no errors were
# found.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::cmdMZ {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: expr # # This file contains the original set of tests for the compilation (and # indirectly execution) of Tcl's expr command. A new set of tests covering # the new implementation are in the files "parseExpr.test" and # "compExpr.test". 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 20 21 22 23 24 25 26 27 |
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: expr
#
# This file contains the original set of tests for the compilation (and
# indirectly execution) of Tcl's expr command. A new set of tests covering
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the file
# tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # This file contains tests for the files tclCompile.c, tclCompCmds.c and # tclLiteral.c # # 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. # | > > > > > > > > > > > > > < < < < < | 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 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the files tclCompile.c, tclCompCmds.c and
# tclLiteral.c
#
# 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.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: concat
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test concat-1.1 {simple concatenation} {
|
| ︙ | ︙ |
|
| < < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: pkgconfig
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test pkgconfig-1.1 {query keys} -body {
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for Tcl_CallWhenDeleted.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 | # This test file covers the dictionary object type and the dict command used # to work with values of that type. # # 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. | > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2003-2009 Donal K. Fellows
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This test file covers the dictionary object type and the dict command used
# to work with values of that type.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
}}
} -returnCodes error -result {key "d" not known in dictionary}
test dict-3.16 {dict/list shimmering - Bug 3004007} testobj {
set l [list p 1 p 2 q 3]
dict get $l q
list $l [testobj objtype $l]
} {{p 1 p 2 q 3} dict}
test dict-4.1 {dict replace command} {
dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
dict replace {a b c d} e f
} {a b c d e f}
| > > > > > > > | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
}}
} -returnCodes error -result {key "d" not known in dictionary}
test dict-3.16 {dict/list shimmering - Bug 3004007} testobj {
set l [list p 1 p 2 q 3]
dict get $l q
list $l [testobj objtype $l]
} {{p 1 p 2 q 3} dict}
test dict-3.17 {dict/list shimmering - Bug 3004007} testobj {
# In Tcl unchained the internal representation is converted to a list
# because there are duplicate keys in the dictionary.
set l [list p 1 p 2 q 3]
dict get $l q
list [llength $l] [testobj objtype $l]
} {6 list}
test dict-4.1 {dict replace command} {
dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
dict replace {a b c d} e f
} {a b c d e f}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for Tcl's dynamic string library
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint exec [llength [info commands exec]]
# 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 {
| > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
variable x
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint teststringbytes [llength [info commands teststringbytes]]
testConstraint exec [llength [info commands exec]]
# 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 {
|
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
encoding system iso8859-1
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
lappend x [catch {encoding convertto shiftjis 乎} msg] $msg
} -cleanup {
encoding system iso8859-1
encoding dirs $path
encoding system $system
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
encoding system iso8859-1
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
lappend x [catch {encoding convertto shiftjis 乎} msg] $msg
} -cleanup {
encoding system iso8859-1
encoding dirs $path
encoding system $system
} -result "\x8c\xc1 1 {unknown encoding \"shiftjis\"}"
test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
set old [encoding system]
} -body {
encoding system shiftjis
encoding system
} -cleanup {
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary
| | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary
puts -nonewline $f "ab\x8c\xc1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation lf -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
| | | | | | | 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 |
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} "ab\x8c\xc1g"
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
encoding dirs {}
llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal
set x [list [catch {encoding convertto jis0208 乎} msg] $msg]
encoding dirs $path
encoding system $system
lappend x [encoding convertto jis0208 乎]
} {1 {unknown encoding "jis0208"} 8C}
test encoding-11.2 {LoadEncodingFile: single-byte} {
encoding convertfrom jis0201 \xa1
} 。
test encoding-11.3 {LoadEncodingFile: double-byte} {
encoding convertfrom jis0208 8C
} 乎
test encoding-11.4 {LoadEncodingFile: multi-byte} {
encoding convertfrom shiftjis \x8c\xc1
} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
encoding convertto iso2022 乎
} \x1b\$B8C\x1b(B
test encoding-11.5.1 {LoadEncodingFile: escape file} {
encoding convertto iso2022-jp 乎
} \x1b\$B8C\x1b(B
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
} -body {
cd [temporaryDirectory]
encoding dirs [file join tmp encoding]
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
encoding convertto utf-16le 😹
} =Ø9Þ
test encoding-11.9 {encoding: extended Unicode UTF-16} {
encoding convertto utf-16be 😹
} Ø=Þ9
test encoding-11.10 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32le 😹
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | > > > > > > | | | | | | > > > > > > > | | > > > | | | | | | | | | | | | | | | | | | | | 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 |
encoding convertto utf-16le 😹
} =Ø9Þ
test encoding-11.9 {encoding: extended Unicode UTF-16} {
encoding convertto utf-16be 😹
} Ø=Þ9
test encoding-11.10 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32le 😹
} 9\xf6\x01\x00
test encoding-11.11 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32be 😹
} \x00\x01\xf69
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
set x [encoding convertto iso8859-3 Ġ]
append x [encoding convertto -profile tcl8 iso8859-3 Õ]
append x [encoding convertfrom iso8859-3 Õ]
} "Õ?Ġ"
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
set x [encoding convertto iso8859-3 abĠg]
append x [encoding convertfrom iso8859-3 abÕg]
} "abÕgabĠg"
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
set x [encoding convertto shiftjis ab乎g]
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
} "ab\x8c\xc1gab乎g"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
set x [encoding convertto jis0208 乎α]
append x [encoding convertfrom jis0208 8C&A]
} "8C&A乎α"
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
set x [encoding convertto symbol γ]
append x [encoding convertto symbol g]
append x [encoding convertfrom symbol g]
} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
encoding convertto iso2022 ab乎棙g
} ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 £
} "\xc2\xa3"
test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z
set z
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]]
binary scan [teststringbytes $y] H* z
set z
} c080
test encoding-15.4 {UtfToUtfProc emoji character input} -body {
set x \xed\xa0\xbd\xed\xb8\x82
set y [encoding convertfrom -profile tcl8 utf-8 \xed\xa0\xbd\xed\xb8\x82]
list [string length $x] $y
} -result "6 \ud83d\ude02"
test encoding-15.5 {UtfToUtfProc emoji character input} {
set x \xf0\x9f\x98\x82
set y [encoding convertfrom utf-8 \xf0\x9f\x98\x82]
list [string length $x] $y
} "4 😂"
test encoding-15.6 {UtfToUtfProc emoji character output} {
set x \ude02\ud83d\ude02\ud83d
set y [encoding convertto -profile tcl8 utf-8 \ude02\ud83d\ude02\ud83d]
binary scan $y H* z
list [string length $y] $z
} {12 edb882eda0bdedb882eda0bd}
test encoding-15.7 {UtfToUtfProc emoji character output} {
set x \ude02\ud83d\ud83d
set y [encoding convertto -profile tcl8 utf-8 \ude02\ud83d\ud83d]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 9 edb882eda0bdeda0bd}
test encoding-15.8 {UtfToUtfProc emoji character output} {
set x \ude02\ud83dé
set y [encoding convertto -profile tcl8 utf-8 \ude02\ud83dé]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 8 edb882eda0bdc3a9}
test encoding-15.9 {UtfToUtfProc emoji character output} {
set x \ude02\ud83dx
set y [encoding convertto -profile tcl8 utf-8 \ude02\ud83dX]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 7 edb882eda0bd58}
test encoding-15.10 {UtfToUtfProc high surrogate character output} {
set x \ude02é
set y [encoding convertto -profile tcl8 utf-8 \ude02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 edb882c3a9}
test encoding-15.11 {UtfToUtfProc low surrogate character output} {
set x \uda02é
set y [encoding convertto -profile tcl8 utf-8 \uDA02é]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 eda882c3a9}
test encoding-15.12 {UtfToUtfProc high surrogate character output} {
set x \ude02Y
set y [encoding convertto -profile tcl8 utf-8 \ude02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 edb88259}
test encoding-15.13 {UtfToUtfProc low surrogate character output} {
set x \uda02Y
set y [encoding convertto -profile tcl8 utf-8 \uda02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 eda88259}
test encoding-15.14 {UtfToUtfProc high surrogate character output} {
set x \ude02
set y [encoding convertto -profile tcl8 utf-8 \ude02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uda02
set y [encoding convertto -profile tcl8 utf-8 \uda02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xf0\xa0\xa1\xc2
set y [encoding convertfrom -profile tcl8 utf-8 \xf0\xa0\xa1\xc2]
list [string length $x] $y
} "4 \xf0\xa0\xa1\xc2"
test encoding-15.17 {UtfToUtfProc emoji character output} {
set x 😂
set y [encoding convertto utf-8 😂]
binary scan $y H* z
list [string length $y] $z
} {4 f09f9882}
test encoding-15.18 {UtfToUtfProc CESU-8 6-byte sequence} {
set y [encoding convertto cesu-8 \U10000]
binary scan $y H* z
list [string length $y] $z
} {6 eda080edb080}
test encoding-15.19 {UtfToUtfProc CESU-8 upper surrogate} {
set y [encoding convertto cesu-8 \ud800]
binary scan $y H* z
list [string length $y] $z
} {3 eda080}
test encoding-15.20 {UtfToUtfProc CESU-8 lower surrogate} {
set y [encoding convertto cesu-8 \udc00]
binary scan $y H* z
list [string length $y] $z
} {3 edb080}
test encoding-15.21 {UtfToUtfProc CESU-8 noncharacter} {
set y [encoding convertto cesu-8 \uffff]
binary scan $y H* z
list [string length $y] $z
} {3 efbfbf}
test encoding-15.22 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
set y [encoding convertto cesu-8 \x80]
binary scan $y H* z
list [string length $y] $z
} {2 c280}
test encoding-15.23 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
set y [encoding convertto cesu-8 \u100]
binary scan $y H* z
list [string length $y] $z
} {2 c480}
test encoding-15.24 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} {
set y [encoding convertto cesu-8 \u3ff]
binary scan $y H* z
list [string length $y] $z
} {2 cfbf}
test encoding-15.25 {UtfToUtfProc CESU-8} {
encoding convertfrom cesu-8 \x00
} \x00
test {encoding-15.26 cesu-8 tclnull default} {UtfToUtfProc CESU-8} -body {
encoding convertfrom cesu-8 \xc0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-15.26 cesu-8 tclnull strict} {UtfToUtfProc CESU-8} -body {
encoding convertfrom -profile strict cesu-8 \xc0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-15.26 cesu-8 tclnull tcl8} {UtfToUtfProc CESU-8} {
encoding convertfrom -profile tcl8 cesu-8 \xc0\x80
} \x00
test encoding-15.27 {UtfToUtfProc -profile strict CESU-8} {
encoding convertfrom -profile strict cesu-8 \x00
} \x00
test encoding-15.28 {UtfToUtfProc -profile strict CESU-8} -body {
encoding convertfrom -profile strict cesu-8 \xc0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-15.29 {UtfToUtfProc CESU-8} {
encoding convertto cesu-8 \x00
} \x00
test encoding-15.30 {UtfToUtfProc -profile strict CESU-8} {
encoding convertto -profile strict cesu-8 \x00
} \x00
test encoding-15.31 {UtfToUtfProc -profile strict CESU-8 (bytes F0-F4 are invalid)} -body {
encoding convertfrom -profile strict cesu-8 \xf1\x86\x83\x9c
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'}
test encoding-15.32 {UtfToUtfProc CESU-8 [2f22a7364d]} -body {
encoding convertto cesu-8 \U1f600
} -result \xED\xA0\xBD\xED\xB8\x80
test encoding-16.1 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.2 {Utf16ToUtfProc} -body {
set val [encoding convertfrom utf-16 "\xd8\xd8\xdc\xdc"]
list $val [format %x [scan $val %c]]
} -result "\U460dc 460dc"
test encoding-16.3 {Utf16ToUtfProc} -body {
set val [encoding convertfrom -profile tcl8 utf-16 "\xdc\xdc"]
list $val [format %x [scan $val %c]]
} -result "\udcdc dcdc"
test encoding-16.4 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.5 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 "\xd8\xd8\xdc\xdc"]
list $val [format %x [scan $val %c]]
} -result "\U460dc 460dc"
test encoding-16.6 {Utf32ToUtfProc} -body {
set val [encoding convertfrom utf-32le NN\0\0]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.7 {Utf32ToUtfProc} -body {
set val [encoding convertfrom utf-32be \0\0NN]
list $val [format %x [scan $val %c]]
} -result "乎 4e4e"
test encoding-16.8 {Utf32ToUtfProc} -body {
set val [encoding convertfrom -profile tcl8 utf-32 \x41\x00\x00\x41]
list $val [format %x [scan $val %c]]
} -result "\ufffd fffd"
test encoding-16.9 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xd8\x00\x00
} -result \ud800
test encoding-16.10 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xdc\x00\x00
} -result \udc00
test encoding-16.11 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xd8\x00\x00\x00\xdc\x00\x00
} -result \ud800\udc00
test encoding-16.12 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32le \x00\xdc\x00\x00\x00\xd8\x00\x00
} -result \udc00\ud800
test encoding-16.13 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xd8
} -result \ud800
test encoding-16.14 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xdc
} -result \udc00
test encoding-16.15 {Utf16ToUtfProc} -body {
encoding convertfrom utf-16le \x00\xd8\x00\xdc
} -result \U010000
test encoding-16.16 {Utf16ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-16le \x00\xdc\x00\xd8
} -result \udc00\ud800
test encoding-16.17 {Utf32ToUtfProc} -body {
list [encoding convertfrom -profile strict -failindex idx utf-32le \x41\x00\x00\x00\x00\xd8\x00\x00\x42\x00\x00\x00] [set idx]
} -result {A 4}
test encoding-16.18 {
Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16
} -body {
apply [list {} {
for {set i 0xD800} {$i < 0xdbff} {incr i} {
for {set j 0xDC00} {$j < 0xdfff} {incr j} {
set string [binary format S2 [list $i $j]]
set status [catch {
set decoded [encoding convertfrom utf-16be $string]
set encoded [encoding convertto utf-16be $decoded]
}]
if {$status || ( $encoded ne $string )} {
return [list [format %x $i] [format %x $j]]
}
}
}
return done
} [namespace current]]
} -result done
test encoding-16.19.strict {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test encoding-16.19.tcl8 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test encoding-16.19.tcl8 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-16 "\x41\x41\x41"
} -result \u4141\ufffd
test encoding-16.19.strict {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\x41\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 2: '\x41'}
test encoding-16.20 {utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom utf-16 "\xd8\xd8"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xD8'}
test encoding-16.20-tcl8 {utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-16 "\xD8\xD8"
} -result \uD8D8
test encoding-16.20-strict {utf16ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-16 "\xd8\xd8"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xD8'}
test encoding-16.21.tcl8 {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile tcl8 utf-32 "\x00\x00\x00\x00\x41\x41"
} -result \x00\ufffd
test encoding-16.21.strict {Utf32ToUtfProc, bug [d19fe0a5b]} -body {
encoding convertfrom -profile strict utf-32 "\x00\x00\x00\x00\x41\x41"
} -returnCodes 1 -result {unexpected byte sequence starting at index 4: '\x41'}
test encoding-16.22 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
encoding convertfrom -profile strict utf-16le \x00\xd8
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-16.23 {Utf16ToUtfProc, strict, bug [db7a085bd9]} -body {
encoding convertfrom -profile strict utf-16le \x00\xdc
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
test {encoding-16.24 utf-8 invalid default} {Parse invalid utf-8, strict} -body {
string length [encoding convertfrom utf-8 "\xC0\x80"]
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-16.24 utf-8 invalid strict} {Parse invalid utf-8, strict} -body {
string length [encoding convertfrom -profile strict utf-8 "\xc0\x80"]
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-16.24 utf-8 invalid tcl8} {UtfToUtfProc utf-8} {
encoding convertfrom -profile tcl8 utf-8 \xc0\x80
} \x00
test {encoding-16.25 default} {Utf32ToUtfProc} -body {
encoding convertfrom utf-32 "\x01\x00\x00\x01"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x01'}
test encoding-16.25.strict {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32 "\x01\x00\x00\x01"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x01'}
test encoding-16.25.tcl8 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32 "\x01\x00\x00\x01"
} -result \ufffd
test encoding-17.1 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\U460dc"
} -result "\xd8\xd8\xdc\xdc"
test encoding-17.2 {UtfToUcs2Proc} -body {
encoding convertfrom utf-16 \xd8\xd8\xdc\xdc
} -result "\U460dc"
test encoding-17.3 {UtfToUtf16Proc} -body {
encoding convertto -profile tcl8 utf-16be "\udcdc"
} -result "\xdc\xdc"
test encoding-17.4 {UtfToUtf16Proc} -body {
encoding convertto -profile tcl8 utf-16le "\ud8d8"
} -result "\xd8\xd8"
test encoding-17.5 {UtfToUtf32Proc} -body {
encoding convertto utf-32le "\U460dc"
} -result "\xdc\x60\x04\x00"
test encoding-17.6 {UtfToUtf32Proc} -body {
encoding convertto utf-32be "\U460dc"
} -result "\x00\x04\x60\xDC"
test encoding-17.7 {UtfToUtf16Proc} -body {
encoding convertto -profile strict utf-16be "\udcdc"
} -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'}
test encoding-17.8 {UtfToUtf16Proc} -body {
encoding convertto -profile strict utf-16le "\ud8d8"
} -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'}
test encoding-17.9 {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32 "\xff\xff\xff\xff"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\xFF'}
test encoding-17.10 {Utf32ToUtfProc} -body {
encoding convertfrom -profile tcl8 utf-32 "\xff\xff\xff\xff"
} -result \ufffd
test encoding-17.11 {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32le "\x00\xd8\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-17.12 {Utf32ToUtfProc} -body {
encoding convertfrom -profile strict utf-32le "\x00\xdc\x00\x00"
} -returnCodes error -result {unexpected byte sequence starting at index 0: '\x00'}
test encoding-18.1 {TableToUtfProc on invalid input} -body {
list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res
} -result {0 !)}
test encoding-18.2 {TableToUtfProc on invalid input with -profile strict} -body {
list [catch {encoding convertto -profile strict jis0208 \\} res] $res
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
test encoding-21.1 {EscapeToUtfProc} {
} {}
test encoding-22.1 {EscapeFromUtfProc} {
} {}
set iso2022encData "\x1B\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\x1B(B
| | | | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
test encoding-21.1 {EscapeToUtfProc} {
} {}
test encoding-22.1 {EscapeFromUtfProc} {
} {}
set iso2022encData "\x1B\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\x1B(B
\x1b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\x1b(B
\x1b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\x1b(B
casino_japanese@___.com \x1b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\x1b(B
\x1b\$B\$7\$g\$&\$+!)\x1b(B"
set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData]
set iso2022uniData2 "私どもでは、チップご購入時にご登録いただいたご住所をキャッシュアウトの際の
小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお
お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部(
casino_japanese@___.com )までご住所変更済の連絡をいただけないで
しょうか?"
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab乎棙g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}
| | | | | | | | | | | > > > | | | | | | | > > > | > > > > > > > > > | | | | | | | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab乎棙g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
set a "乎乞也"; # 3 Japanese Kanji letters
puts $a
} iso2022.tcl]
set f [open "|[list [interpreter] $file]"]
fconfigure $f -encoding iso2022-jp
set count [gets $f line]
close $f
removeFile iso2022.tcl
list $count $line
} [list 3 乎乞也]
test encoding-24.4.strict {Parse invalid utf-8, strict} -body {
encoding convertfrom -profile strict utf-8 "\xc0\x80"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-24.4.tcl8 {UtfToUtfProc utf-8} {
encoding convertfrom -profile tcl8 utf-8 \xc0\x80
} \x00
test encoding-24.5 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xc0\x81"]
} 2
test encoding-24.6 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xc1\xBF"]
} 2
test encoding-24.7 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xc2\x80"]
} 1
test encoding-24.8 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xe0\x80\x80"]
} 3
test encoding-24.9 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xe0\x9f\xbf"]
} 3
test encoding-24.10 {Parse valid or invalid utf-8} {
string length [encoding convertfrom utf-8 "\xe0\xa0\x80"]
} 1
test encoding-24.11 {Parse valid or invalid utf-8} {
string length [encoding convertfrom -profile tcl8 utf-8 "\xef\xbf\xbf"]
} 1
test encoding-24.12.default {Parse invalid utf-8} -body {
encoding convertfrom utf-8 "\xC0\x81"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-24.12.tcl8 {Parse invalid utf-8} -body {
encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"
} -result \xC0\x81
test encoding-24.12.strict {Parse invalid utf-8} -body {
encoding convertfrom -profile strict utf-8 "\xC0\x81"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-24.13.default {Parse invalid utf-8} -body {
encoding convertfrom -profile strict utf-8 "\xc1\xbf"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'}
test encoding-24.13.strict {Parse invalid utf-8} -body {
encoding convertfrom -profile strict utf-8 "\xc1\xbf"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'}
test encoding-24.13.tcl8 {Parse invalid utf-8} -body {
encoding convertfrom -profile tcl8 utf-8 "\xC1\xBF"
} -result \xC1\xBF
test encoding-24.14.default {Parse valid utf-8} {
encoding convertfrom utf-8 "\xC2\x80"
} \x80
test encoding-24.14.strict {Parse valid utf-8} {
encoding convertfrom -profile strict utf-8 "\xC2\x80"
} \x80
test encoding-24.14.tcl8 {Parse valid utf-8} {
encoding convertfrom -profile tcl8 utf-8 "\xC2\x80"
} \x80
test encoding-24.15.default {Parse invalid utf-8, default} -body {
encoding convertfrom -profile strict utf-8 "Z\xe0\x80"
} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'"
test encoding-24.15.strict {Parse invalid utf-8, -profile strict} -body {
encoding convertfrom -profile strict utf-8 "Z\xe0\x80"
} -returnCodes 1 -result "unexpected byte sequence starting at index 1: '\\xE0'"
test encoding-24.15.tcl8 {Parse invalid utf-8, -profile tcl8} -body {
encoding convertfrom -profile tcl8 utf-8 "Z\xe0\x80"
} -result Z\xe0\u20ac
test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body {
encoding convertto utf-8 [testbytestring "Z\u4343\x80"]
} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃' (U+004343)}
test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body {
encoding convertto utf-8 [testbytestring "Z\xe0\x80"]
} -result "Z\xC3\xa0\xe2\x82\xac"
test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body {
encoding convertto utf-8 [testbytestring "Z\xe0\x80xxxxxx"]
} -result "Z\xc3\xa0\xe2\x82\xacxxxxxx"
test encoding-24.19.1 {Parse valid or invalid utf-8} -body {
encoding convertto -profile tcl8 utf-8 "ZX\ud800"
} -result ZX\xed\xa0\x80
test encoding-24.19.2 {Parse valid or invalid utf-8} -body {
encoding convertto -profile strict utf-8 "ZX\ud800"
} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'"
test encoding-24.19.3 {Parse valid or invalid utf-8} -body {
encoding convertto utf-8 "ZX\ud800"
} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'"
test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -body {
encoding convertfrom -profile tcl8 "\x20"
} -result {wrong # args: should be "::tcl::encoding::convertfrom ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertfrom data"} -returnCodes error
test encoding-24.21 {Parse with -profile tcl8 but without providing encoding} -body {
string length [encoding convertto -profile tcl8 "\x20"]
} -result {wrong # args: should be "::tcl::encoding::convertto ?-profile profile? ?-failindex var? encoding data" or "::tcl::encoding::convertto data"} -returnCodes error
test encoding-24.22 {Syntax error, two encodings} -body {
encoding convertfrom iso8859-1 utf-8 "ZX\ud800"
} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error
test encoding-24.23 {Syntax error, two encodings} -body {
encoding convertto iso8859-1 utf-8 "ZX\ud800"
} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error
test encoding-24.24 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 "\xc0\x80\x00\x00"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test encoding-24.25 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 "\x40\x80\x00\x00"
} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'}
test encoding-24.26 {Parse valid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 "\xf1\x80\x80\x80"
} -result \U40000
test encoding-24.27 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 "\xf0\x80\x80\x80"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'}
test encoding-24.28 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 "\xff\x00\x00"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'}
test encoding-24.29 {Parse invalid utf-8} -body {
encoding convertfrom utf-8 \xef\xbf\xbf
} -result \uffff
test encoding-24.30 {Parse noncharacter with -profile strict} -body {
encoding convertfrom -profile strict utf-8 \xef\xbf\xbf
} -result \uffff
test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body {
encoding convertfrom -profile tcl8 utf-8 \xef\xbf\xbf
} -result \uffff
test encoding-24.33 {Try to generate invalid utf-8} -body {
encoding convertto utf-8 \uffff
} -result \xef\xbf\xbf
test encoding-24.33 {Try to generate invalid utf-8} -body {
encoding convertto -profile strict utf-8 \uffff
} -result \xef\xbf\xbf
test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body {
encoding convertto -profile tcl8 utf-8 \uffff
} -result \xef\xbf\xbf
test encoding-24.35 {Parse invalid utf-8} -body {
encoding convertfrom -profile tcl8 utf-8 \xed\xa0\x80
} -result \ud800
test encoding-24.36 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 \xed\xa0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'}
test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body {
encoding convertfrom -profile tcl8 utf-8 \xed\xa0\x80
} -result \ud800
test encoding-24.38.1 {Try to generate invalid utf-8} -body {
encoding convertto -profile tcl8 utf-8 \ud800
} -result \xed\xa0\x80
test {encoding-24.38.2 default} {Try to generate invalid utf-8} -body {
encoding convertto -profile strict utf-8 \ud800
} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
test {encoding-24.38.2 strict} {Try to generate invalid utf-8} -body {
encoding convertto -profile strict utf-8 \ud800
} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
test encoding-24.39 {Try to generate invalid utf-8 with -profile strict} -body {
encoding convertto -profile strict utf-8 \ud800
} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
test encoding-24.40 {Try to generate invalid utf-8 with -profile tcl8} -body {
encoding convertto -profile tcl8 utf-8 \ud800
} -result \xed\xa0\x80
test encoding-24.41 {Parse invalid utf-8 with -profile strict} -body {
encoding convertfrom -profile strict utf-8 \xed\xa0\x80\xed\xb0\x80
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'}
test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body {
encoding convertfrom -profile tcl8 utf-8 \xf0\x80\x80\x80
} -result \xf0\u20ac\u20ac\u20ac
test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body {
encoding convertfrom -profile tcl8 utf-8 \x80
} -result \u20ac
test encoding-24.44 {Try to generate invalid ucs-2 with -profile strict} -body {
encoding convertto -profile strict ucs-2 \ud800
} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'}
test encoding-24.45 {Try to generate invalid ucs-2 with -profile strict} -body {
encoding convertto -profile strict ucs-2 \U10000
} -returnCodes 1 -result {unexpected character at index 0: 'U+010000'}
file delete [file join [temporaryDirectory] iso2022.txt]
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
}
proc gen-jisx0208-euc-jp {code} {
binary format cc \
[expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}]
}
proc gen-jisx0208-iso2022-jp {code} {
binary format a3cca3 \
| | | 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 |
}
proc gen-jisx0208-euc-jp {code} {
binary format cc \
[expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}]
}
proc gen-jisx0208-iso2022-jp {code} {
binary format a3cca3 \
"\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xFF}] "\x1b(B"
}
proc gen-jisx0208-cp932 {code} {
set c1 [expr {($code >> 8) | 0x80}]
set c2 [expr {($code & 0xff)| 0x80}]
if {$c1 % 2} {
set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x31 : 0x71)}]
incr c2 [expr {- (0x60 + ($c2 < 0xE0))}]
|
| ︙ | ︙ | |||
1073 1074 1075 1076 1077 1078 1079 |
} -result 93
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
| | | | | | | 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 |
} -result 93
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xff
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1} result] $result
} -result [list 0 [list nospace {} \xFF]]
test encoding-bug-183a1adcc0-2 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xff
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 0} result] $result
} -result [list 0 [list nospace {} {}]]
test encoding-bug-183a1adcc0-3 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xff
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 2} result] $result
} -result [list 0 [list nospace {} \x00\x00]]
test encoding-bug-183a1adcc0-4 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xff
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 3} result] $result
} -result [list 0 [list nospace {} \x00\x00\xff]]
test encoding-bug-183a1adcc0-5 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 4} result] $result
} -result [list 0 [list ok {} [expr {$::tcl_platform(byteOrder) eq "littleEndian" ? "\x41\x00" : "\x00\x41"}]\x00\x00]]
|
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 |
[testencoding nullength ksc5601]
} -result {1 2 4 2 2}
test encoding-30.0 {encoding convertto large strings UINT_MAX} -constraints {
perf
} -body {
# Test to ensure not misinterpreted as -1
| | | | | | | | | | | 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 |
[testencoding nullength ksc5601]
} -result {1 2 4 2 2}
test encoding-30.0 {encoding convertto large strings UINT_MAX} -constraints {
perf
} -body {
# Test to ensure not misinterpreted as -1
list [string length [set s [string repeat A 0xffffffff]]] [string equal $s [encoding convertto ascii $s]]
} -result {4294967295 1}
test encoding-30.1 {encoding convertto large strings > 4GB} -constraints {
perf
} -body {
list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertto ascii $s]]
} -result {4294967296 1}
test encoding-30.2 {encoding convertfrom large strings UINT_MAX} -constraints {
perf
} -body {
# Test to ensure not misinterpreted as -1
list [string length [set s [string repeat A 0xffffffff]]] [string equal $s [encoding convertfrom ascii $s]]
} -result {4294967295 1}
test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints {
perf
} -body {
list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]]
} -result {4294967296 1}
test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7aaby
} -result x\ufffdy
test encoding-bug-6a3e2cb0f0-2 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile strict iso2022-jp x\x1b\x7aaby
} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x1B'}
test encoding-bug-6a3e2cb0f0-3 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile replace iso2022-jp x\x1b\x7aaby
} -result x\ufffdy
test encoding-bug-66ffafd309-1-tcl8 {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile tcl8 gb12345 x
} -result x
test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile strict gb12345 x
} -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error
test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile replace gb12345 x
} -result \ufffd
test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile tcl8 jis0208 \x78\x79
} -result \x78\x79
test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile strict jis0208 \x78\x79
} -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error
test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile replace jis0208 \x78\x79
} -result \ufffd\ufffd
test encoding-bug-201c7a3aa6-strict {Crash encoding non-BMP to iso2022} -body {
encoding convertto -profile strict iso2022 \U1f600
} -result {unexpected character at index 0: 'U+01F600'} -returnCodes error
test encoding-bug-201c7a3aa6-replace {Crash encoding non-BMP to iso2022} -body {
encoding convertto -profile replace iso2022 \U1f600
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # This file contains test vectors for verifying various encodings. They are # stored in a common file so that they can be sourced into the various test # modules that are dependent on encodings. This file contains statically defined # test vectors. In addition, it sources the ICU-generated test vectors from # icuUcmTests.tcl. # # Note that sourcing the file will reinitialize any existing encoding test # vectors. | > > > > > > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains test vectors for verifying various encodings. They are
# stored in a common file so that they can be sourced into the various test
# modules that are dependent on encodings. This file contains statically defined
# test vectors. In addition, it sources the ICU-generated test vectors from
# icuUcmTests.tcl.
#
# Note that sourcing the file will reinitialize any existing encoding test
# vectors.
# List of defined encoding profiles
set encProfiles {tcl8 strict replace}
set encDefaultProfile strict; # Should reflect the default from implementation
# encValidStrings - Table of valid strings.
#
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none (tests environment variable implementation)
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: error, catch, throw, try
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: eval
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test eval-1.1 {single argument} {
|
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1995-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
package require tcltest 2.5
namespace import -force ::tcltest::*
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# There is no point in running Valgrind on cases where [exec] forks but then
# fails and the child process doesn't go through full cleanup.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: exec
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 |
viewFile $log
} -result "\"Testing exec-20.0\""
test exec-20.1 {exec .CMD file} -constraints {win} -body {
set log [makeFile {} exec201.log]
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
viewFile $log
} -result "\"Testing exec-20.1\""
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
viewFile $log
} -result "\"Testing exec-20.0\""
test exec-20.1 {exec .CMD file} -constraints {win} -body {
set log [makeFile {} exec201.log]
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
viewFile $log
} -result "\"Testing exec-20.1\""
# ----------------------------------------------------------------------
# cleanup
foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} {
removeFile $file
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | # This file contains tests for the tclExecute.c source file. Tests appear in # the same order as the C code that they test. The set of tests is currently # incomplete since it currently includes only new tests for code changed for # the addition of Tcl namespaces. Other execution-related tests appear in # several other test files including namespace.test, basic.test, eval.test, # for.test, etc. # # 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the tclExecute.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is currently
# incomplete since it currently includes only new tests for code changed for
# the addition of Tcl namespaces. Other execution-related tests appear in
# several other test files including namespace.test, basic.test, eval.test,
# for.test, etc.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # Commands covered: expr # # This file contains the original set of tests for Tcl's expr command. # Since the expr command is now compiled, a new set of tests covering # the new implementation are in the files "parseExpr.test" and # "compExpr.test". 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: expr
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: expr
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclFCmd.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the filename manipulation routines.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
1 2 3 4 5 | # This file tests the filesystem and vfs internals. # # 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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2002 Vincent Darley.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the filesystem and vfs internals.
#
# 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.
namespace eval ::tcl::test::fileSystem {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
1 2 | #! /usr/bin/env tclsh | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
#! /usr/bin/env tclsh
# Copyright © 2019 Nathan Coulter
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
}
namespace eval ::tcl::test::fileSystemEncoding {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: for, continue, break # # This file contains the original set of tests for Tcl's for command. # Since the for command is now compiled, a new set of tests covering # the new implementation is in the file "for.test". 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 20 21 22 23 24 25 26 27 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: for, continue, break
#
# This file contains the original set of tests for Tcl's for command.
# Since the for command is now compiled, a new set of tests covering
# the new implementation is in the file "for.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Check "for" and its use of continue and break.
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: for, 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. | > > > > > > > > > > > > | < < < < | 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 © 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.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: for, 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: foreach, 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset a}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: format
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# %z/%t/%p output depends on pointerSize, so some tests are not portable.
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for the procedures in the
# file tclGet.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: history
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# The history command might be autoloaded...
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: http::config, http::geturl, http::wait, http::reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# http11.test -- -*- tcl-*-
#
# Test HTTP/1.1 features.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
|
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# httpPipeline.test
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2022-2023 Keith Nash.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: http::geturl when using a proxy server.
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.10
|
| ︙ | ︙ |
1 2 3 4 5 | # httpTest.tcl # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # | > > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# httpTest.tcl
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# ------------------------------------------------------------------------------
# "Package" httpTest for analysis of Log output of http requests.
# ------------------------------------------------------------------------------
# This is a specialised test kit for examining the presence, ordering, and
# overlap of multiple HTTP transactions over a persistent ("Keep-Alive")
# connection; and also for testing reconnection in accordance with RFC 7230 when
|
| ︙ | ︙ |
1 2 3 4 5 | # httpTestScript.tcl # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # | > > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Copyright © 2018 Keith Nash <kjnash@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # httpTestScript.tcl # # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # # ------------------------------------------------------------------------------ # "Package" httpTestScript for executing test scripts written in a convenient # shorthand. # ------------------------------------------------------------------------------ # ------------------------------------------------------------------------------ |
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: http::cookiejar # # This file contains a collection of tests for the cookiejar package. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2014 Donal K. Fellows.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: http::cookiejar
#
# This file contains a collection of tests for the cookiejar package.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Copyright © 1997-1998 Sun Microsystems, Inc. # Copyright © 1999-2000 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # The httpd_ procedures implement a stub http server. #set httpLog 1 # Do not use [info hostname]. # Name resolution is often a problem on OSX; not focus of HTTP package anyway. # Also a problem on other platforms for http-4.14 (test with bad port number). set HOST localhost |
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# httpd11.tcl -- -*- tcl -*-
#
# A simple httpd for testing HTTP/1.1 client features.
# Not suitable for use on a internet connected port.
package require Tcl
proc ::tcl::dict::get? {dict key} {
if {[dict exists $dict $key]} {
return [dict get $dict $key]
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # This file is automatically generated by ucm2tests.tcl. # Edits will be overwritten on next generation. # # Tests comparing Tcl encodings to ICU. # This file is NOT standalone. It should be sourced into a test script. | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file is automatically generated by ucm2tests.tcl. # Edits will be overwritten on next generation. # # Tests comparing Tcl encodings to ICU. # This file is NOT standalone. It should be sourced into a test script. |
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: if # # This file contains the original set of tests for Tcl's if command. # Since the if command is now compiled, a new set of tests covering # the new implementation is in the file "if.test". 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 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: if
#
# This file contains the original set of tests for Tcl's if command.
# Since the if command is now compiled, a new set of tests covering
# the new implementation is in the file "if.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test if-old-1.1 {taking proper branch} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: if
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Basic "if" operation.
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: incr # # This file contains the original set of tests for Tcl's incr command. # Since the incr command is now compiled, a new set of tests covering # the new implementation is in the file "incr.test". 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 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: incr
#
# This file contains the original set of tests for Tcl's incr command.
# Since the incr command is now compiled, a new set of tests covering
# the new implementation is in the file "incr.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {unset x}
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: incr # # 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. | > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: incr
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain x i
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file is a Tcl script to test out the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here are
# organized in the standard fashion for Tcl tests.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < < > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2006 ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: info
#
# 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.
#
# The tests below hard-code line numbers in this very script in order to test
# for correct reporting of line-numbers. In order to provide at least some
# space where lines may be added without messing up these tests, the last line
# of this comment is used to obtain an offset that is then used to make the
# hard-coded line numbers not sensitive to changes in the number of lines at
# the beginning of this file. When developing/debugging, it can be useful to
# temporarily delete enough lines from the top of this file that the offset
# becomes 0.
#
# DO NOT DELETE THIS LINE
if {{::tcltest} ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
} {a bbb c}
test info-1.2 {info args option} {
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
| > > > > > > > > > > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
set chan [open [info script]]
set thisscript [read $chan]
close $chan
set topcomments [regexp -inline {^.*?DO NOT DELETE THIS LINE\n} $thisscript]
set offset [llength [split $topcomments \n]]
# The original 9 lines in the top comments are already counted in the
# hard-coded values in this file
incr offset -7
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
} {a bbb c}
test info-1.2 {info args option} {
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 |
test info-22.2 {info frame, bad level absolute} {!singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame 9} msg
set msg
} {bad level "9"}
test info-22.3 {info frame, current, relative} -match glob -body {
info frame 0
| | | | | | | | | | 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 |
test info-22.2 {info frame, bad level absolute} {!singleTestInterp} {
# catch is another level!, i.e. we have 8, not 7
catch {info frame 9} msg
set msg
} {bad level "9"}
test info-22.3 {info frame, current, relative} -match glob -body {
info frame 0
} -result "type source line [expr {$offset + 750}] file */info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-22.4 {info frame, current, relative, nested} -match glob -body {
set res [info frame 0]
} -result "type source line [expr {$offset + 753}] file */info.test cmd {info frame 0} proc ::tcltest::RunTest" -cleanup {unset res}
test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body {
reduce [info frame 7]
} -result "type source line [expr {$offset + 756}] file info.test cmd {info frame 7} proc ::tcltest::RunTest"
test info-22.6 {info frame, global, relative} {!singleTestInterp} {
reduce [info frame -6]
} "type source line [expr {$offset + 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 [expr {$offset + 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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type source line [expr {$offset + 765}] file info.test cmd etrace proc ::tcltest::RunTest}
* {type source line * file tcltest* cmd {uplevel 1 \$script} proc ::tcltest::RunTest}"
unset -nocomplain msg
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
i eval { set script {info frame}
eval $script}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.3 {eval'd info frame, literal} -match glob -body {
eval {
info frame 0
}
| | | | | 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 |
i eval { set script {info frame}
eval $script}
} -setup {interp create i} -cleanup {interp delete i} -result 2
test info-23.3 {eval'd info frame, literal} -match glob -body {
eval {
info frame 0
}
} -result "type source line [expr {$offset + 793}] file * cmd {info frame 0} proc ::tcltest::RunTest"
test info-23.4 {eval'd info frame, semi-dynamic} {
eval info frame 0
} {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line [expr {$offset + 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',
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
# location. The command implementations execute such scripts through
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
proc bar {} {info frame 0}
}
test info-24.0 {info frame, interaction, namespace eval} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
| | | | | | | | | | 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 |
proc bar {} {info frame 0}
}
test info-24.0 {info frame, interaction, namespace eval} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 825}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
set flag 1
if {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.1 {info frame, interaction, if} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 839}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
set flag 1
while {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
set flag 0
};unset flag
test info-24.2 {info frame, interaction, while} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 853}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
catch {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.3 {info frame, interaction, catch} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 867}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
foreach var val {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}; unset var
test info-24.4 {info frame, interaction, foreach} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 880}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
for {} {1} {} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}
test info-24.5 {info frame, interaction, for} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 894}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x {
foo {
proc ::foo::bar {} {info frame 0}
}
}
test info-24.6.0 {info frame, interaction, switch, list body} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
unset x
} -result "type source line [expr {$offset + 910}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x foo {
proc ::foo::bar {} {info frame 0}
}
test info-24.6.1 {info frame, interaction, switch, multi-body} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
unset x
} -result "type source line [expr {$offset + 926}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x [list foo {
proc ::foo::bar {} {info frame 0}
|
| ︙ | ︙ | |||
953 954 955 956 957 958 959 |
namespace eval foo {}
dict for {k v} {foo bar} {
proc ::foo::bar {} {info frame 0}
}
test info-24.7 {info frame, interaction, dict for} {
reduce [foo::bar]
| | | | | | | | 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 |
namespace eval foo {}
dict for {k v} {foo bar} {
proc ::foo::bar {} {info frame 0}
}
test info-24.7 {info frame, interaction, dict for} {
reduce [foo::bar]
} "type source line [expr {$offset + 955}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo; unset k v
# -------------------------------------------------------------------------
namespace eval foo {}
set thedict {foo bar}
dict with thedict {
proc ::foo::bar {} {info frame 0}
}
test info-24.8 {info frame, interaction, dict with} {
reduce [foo::bar]
} "type source line [expr {$offset + 969}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
unset thedict foo
# -------------------------------------------------------------------------
namespace eval foo {}
dict filter {foo bar} script {k v} {
proc ::foo::bar {} {info frame 0}
set x 1
}; unset k v x
test info-24.9 {info frame, interaction, dict filter} {
reduce [foo::bar]
} "type source line [expr {$offset + 983}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
#unset x
# -------------------------------------------------------------------------
eval {
proc bar {} {info frame 0}
}
test info-25.0 {info frame, proc in eval} {
reduce [bar]
} "type source line [expr {$offset + 997}] file info.test cmd {info frame 0} proc ::bar level 0"
# Don't need to clean up yet...
proc bar {} {info frame 0}
test info-25.1 {info frame, regular proc} {
reduce [bar]
} "type source line [expr {$offset + 1005}] file info.test cmd {info frame 0} proc ::bar level 0"
rename bar {}
# -------------------------------------------------------------------------
# More info-30.x test cases at the end of the file.
test info-30.0 {bs+nl in literal words} -cleanup {unset res} -body {
if {1} {
set res \
[reduce [info frame 0]];#1018
}
return $res
# This was reporting line 3 instead of the correct 4 because the
# bs+nl combination is subst by the parser before the 'if'
# command, and the bcc, see the word. Fixed by recording the
# offsets of all bs+nl sequences in literal words, then using the
# information in the bcc and other places to bump line numbers when
# parsing over the location. Also affected: testcases 22.8 and 23.6.
} -result "type source line [expr {$offset + 1018}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
# -------------------------------------------------------------------------
# See 24.0 - 24.5 for similar situations, using literal scripts.
set body {set flag 0
set a c
set res [info frame 0]} ;# line 3!
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
foo
{proc bar {} {info frame 0}}
}
test info-33.0 {{*}, literal, direct} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
| | | | | 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 |
foo
{proc bar {} {info frame 0}}
}
test info-33.0 {{*}, literal, direct} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 1115}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set flag 1
if {*}{
{$flag}
{info frame 0}
}
}
test info-33.1 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 1130}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace {*}"
eval
foo
{proc bar {} {info frame 0}}
"
test info-33.2 {{*}, literal, direct} {
reduce [foo::bar]
} "type source line [expr {$offset + 1144}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
namespace {*}"eval\nfoo\n{proc bar {} {info frame 0}}\n"
|
| ︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 |
if {*}"
{1}
{info frame 0}
"
}
test info-33.3 {{*}, literal, simple, bytecompiled} {
reduce [foo::bar]
| | | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
if {*}"
{1}
{info frame 0}
"
}
test info-33.3 {{*}, literal, simple, bytecompiled} {
reduce [foo::bar]
} "type source line [expr {$offset + 1169}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
|
| ︙ | ︙ | |||
1229 1230 1231 1232 1233 1234 1235 |
apply {
{x y}
{info frame 0}
} 0 0
}
test info-35.0 {apply, literal} {
reduce [foo]
| | | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
apply {
{x y}
{info frame 0}
} 0 0
}
test info-35.0 {apply, literal} {
reduce [foo]
} "type source line [expr {$offset + 1231}] file info.test cmd {info frame 0} lambda {
{x y}
{info frame 0}
} level 0"
rename foo {}
set lambda {
{x y}
{info frame 0}
}
test info-35.1 {apply, dynamic} {
|
| ︙ | ︙ | |||
1258 1259 1260 1261 1262 1263 1264 |
dict for {k v} {foo bar} {
set x [info frame 0]
}
set x
}
test info-36.0 {info frame, dict for, bcc} -body {
reduce [foo::bar]
| | | | | 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 |
dict for {k v} {foo bar} {
set x [info frame 0]
}
set x
}
test info-36.0 {info frame, dict for, bcc} -body {
reduce [foo::bar]
} -result "type source line [expr {$offset + 1259}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set x foo
switch -exact -- $x {
foo {set y [info frame 0]}
}
set y
}
test info-36.1.0 {switch, list literal, bcc} -body {
reduce [foo::bar]
} -result "type source line [expr {$offset + 1275}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set x foo
switch -exact -- $x foo {set y [info frame 0]}
set y
}
test info-36.1.1 {switch, multi-body literals, bcc} -body {
reduce [foo::bar]
} -result "type source line [expr {$offset + 1291}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
test info-37.0 {eval pure list, single line} -match glob -body {
# Basically, counting the newline in the word seen through $foo
|
| ︙ | ︙ | |||
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
| | | | 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
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 [expr {$offset + 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
## DPV direct-proc-var - ditto
## PPV proc-proc-var - ditto
|
| ︙ | ︙ | |||
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
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::tcltest::RunTest}
* {type source line [expr {$offset + 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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line [expr {$offset + 1338}] file info.test cmd {uplevel 1 \$script} proc ::control}
* {type source line [expr {$offset + 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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 3 cmd etrace proc ::control}
* {type source line [expr {$offset + 1338}] file info.test cmd {uplevel 1 \$script} proc ::control}
* {type source line [expr {$offset + 1353}] file info.test cmd {control y \$script} proc ::datav level 1}
* {type source line [expr {$offset + 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 [expr {$offset + 730}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type eval line 1 cmd etrace proc ::tcltest::RunTest}
* {type source line [expr {$offset + 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
test info-39.0 {location information not confused by literal sharing} -body {
namespace eval ::foo {}
proc ::foo::bar {} {
lappend res {}
lappend res [reduce [eval {info frame 0}]]
lappend res [reduce [eval {info frame 0}]]
return $res
}
set res [::foo::bar]
namespace delete ::foo
join $res \n
} -cleanup {unset res} -result "
type source line [expr {$offset + 1427}] file info.test cmd {info frame 0} proc ::foo::bar level 0
type source line [expr {$offset + 1428}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences).
test info-30.1 {bs+nl in literal words, procedure body, compiled} -body {
proc abra {} {
if {1} \
{
return \
[reduce [info frame 0]];# line 1446
}
}
abra
} -cleanup {
rename abra {}
} -result "type source line [expr {$offset + 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 [expr {$offset + 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 [expr {$offset + 1464}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.4 {bs+nl in literal words, eval script} -cleanup {unset res} -body {
eval {
set ::res \
[reduce [info frame 0]];# line 1471
}
return $res
} -result "type source line [expr {$offset + 1471}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.5 {bs+nl in literal words, eval script, with nested words} -body {
eval {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1481
}
}
return $res
} -cleanup {unset res} -result "type source line [expr {$offset + 1481}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.6 {bs+nl in computed word} -cleanup {unset res} -body {
set res "\
[reduce [info frame 0]]";# line 1489
} -result " type source line [expr {$offset + 1489}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.7 {bs+nl in computed word, in proc} -body {
proc abra {} {
return "\
[reduce [info frame 0]]";# line 1495
}
abra
} -cleanup {
rename abra {}
} -result " type source line [expr {$offset + 1495}] file info.test cmd {info frame 0} proc ::abra level 0"
test info-30.8 {bs+nl in computed word, nested eval} -body {
eval {
set \
res "\
[reduce [info frame 0]]";# line 1506
}
} -cleanup {unset res} -result " type source line [expr {$offset + 1506}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.9 {bs+nl in computed word, nested eval} -body {
eval {
set \
res "\
[reduce \
[info frame 0]]";# line 1515
}
} -cleanup {unset res} -result " type source line [expr {$offset + 1515}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.10 {bs+nl in computed word, key to array} -body {
set tmp([set \
res "\
[reduce \
[info frame 0]]"]) x ; #1523
unset tmp
set res
} -cleanup {unset res} -result " type source line [expr {$offset + 1523}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.11 {bs+nl in subst arguments} -body {
subst {[set \
res "\
[reduce \
[info frame 0]]"]} ; #1532
} -cleanup {unset res} -result " type source line [expr {$offset + 1532}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.12 {bs+nl in computed word, nested eval} -body {
eval {
set \
res "\
[set x {}] \
[reduce \
[info frame 0]]";# line 1541
}
} -cleanup {unset res x} -result " type source line [expr {$offset + 1541}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body {
subinterp ; set res [interp eval sub { uplevel #0 {
if {1} \
{
set ::res \
[reduce [info frame 0]];# line 1550
}
}
set res }] ; interp delete sub ; set res
} -cleanup {unset res} -result "type source line [expr {$offset + 1550}] file info.test cmd {info frame 0} level 0"
test info-30.14 {bs+nl, literal word, uplevel through proc} {
subinterp ; set res [interp eval sub { proc abra {script} {
uplevel 1 $script
}
set res [abra {
return "\
[reduce [info frame 0]]";# line 1562
}]
rename abra {}
set res }] ; interp delete sub ; set res
} " type source line [expr {$offset + 1562}] file info.test cmd {info frame 0} proc ::abra"
test info-30.15 {bs+nl in literal words, nested proc body, compiled} {
proc a {} {
proc b {} {
if {1} \
{
return \
[reduce [info frame 0]];# line 1574
}
}
}
a ; set res [b]
rename a {}
rename b {}
set res
} "type source line [expr {$offset + 1574}] file info.test cmd {info frame 0} proc ::b level 0"
test info-30.16 {bs+nl in multi-body switch, compiled} {
proc a {value} {
switch -regexp -- $value \
^key { info frame 0; # 1587 } \
\t### { info frame 0; # 1588 } \
{[0-9]*} { info frame 0; # 1589 }
}
set res {}
lappend res [reduce [a {key }]]
lappend res [reduce [a {1alpha}]]
set res "\n[join $res \n]"
} "
type source line [expr {$offset + 1587}] file info.test cmd {info frame 0} proc ::a level 0
type source line [expr {$offset + 1589}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.17 {bs+nl in multi-body switch, direct} {
switch -regexp -- {key } \
^key { reduce [info frame 0] ;# 1601 } \
\t### { } \
{[0-9]*} { }
} "type source line [expr {$offset + 1601}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} {
proc abra {script} {
append script "\n# end of script"
uplevel 1 $script
}
set res [abra {
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
[info frame 0] }
}
}
set res {}
lappend res [a {key }]
lappend res [a {1alpha}]
set res "\n[join $res \n]"
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
[info frame 0] }
}
}
set res {}
lappend res [a {key }]
lappend res [a {1alpha}]
set res "\n[join $res \n]"
} "
type source line [expr {$offset + 1624}] file info.test cmd {info frame 0} proc ::a level 0
type source line [expr {$offset + 1628}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.20 {bs+nl in single-body switch, direct} {
switch -regexp -- {key } { \
^key { reduce \
[info frame 0] }
\t### { }
{[0-9]*} { }
}
} "type source line [expr {$offset + 1643}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.21 {bs+nl in if, full compiled} {
proc a {value} {
if {$value} \
{info frame 0} \
{info frame 0} ; # 1653
}
set res {}
lappend res [reduce [a 1]]
lappend res [reduce [a 0]]
set res "\n[join $res \n]"
} "
type source line [expr {$offset + 1652}] file info.test cmd {info frame 0} proc ::a level 0
type source line [expr {$offset + 1653}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.22 {bs+nl in computed word, key to array, compiled} {
proc a {} {
set tmp([set \
res "\
[reduce \
[info frame 0]]"]) x ; #1668
unset tmp
set res
}
set res [a]
rename a {}
set res
} " type source line [expr {$offset + 1668}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.23 {bs+nl in multi-body switch, full compiled} {
proc a {value} {
switch -exact -- $value \
key { info frame 0; # 1680 } \
xxx { info frame 0; # 1681 } \
000 { info frame 0; # 1682 }
}
set res {}
lappend res [reduce [a key]]
lappend res [reduce [a 000]]
set res "\n[join $res \n]"
} "
type source line [expr {$offset + 1680}] file info.test cmd {info frame 0} proc ::a level 0
type source line [expr {$offset + 1682}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.24 {bs+nl in single-body switch, full compiled} {
proc a {value} {
switch -exact -- $value {
key { reduce \
[info frame 0] }
xxx { reduce \
[info frame 0] }
000 { reduce \
[info frame 0] }
}
}
set res {}
lappend res [a key]
lappend res [a 000]
set res "\n[join $res \n]"
} "
type source line [expr {$offset + 1696}] file info.test cmd {info frame 0} proc ::a level 0
type source line [expr {$offset + 1700}] file info.test cmd {info frame 0} proc ::a level 0"
test info-30.25 {TIP 280 for compiled [subst]} {
subst {[reduce [info frame 0]]} ; # 1712
} "type source line [expr {$offset + 1712}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.26 {TIP 280 for compiled [subst]} {
subst \
{[reduce [info frame 0]]} ; # 1716
} "type source line [expr {$offset + 1716}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.27 {TIP 280 for compiled [subst]} {
subst {
[reduce [info frame 0]]} ; # 1720
} "
type source line [expr {$offset + 1720}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.28 {TIP 280 for compiled [subst]} {
subst {\
[reduce [info frame 0]]} ; # 1725
} " type source line [expr {$offset + 1725}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.29 {TIP 280 for compiled [subst]} {
subst {foo\
[reduce [info frame 0]]} ; # 1729
} "foo type source line [expr {$offset + 1729}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.30 {TIP 280 for compiled [subst]} {
subst {foo
[reduce [info frame 0]]} ; # 1733
} "foo
type source line [expr {$offset + 1733}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.31 {TIP 280 for compiled [subst]} {
subst {[][reduce [info frame 0]]} ; # 1737
} "type source line [expr {$offset + 1737}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.32 {TIP 280 for compiled [subst]} {
subst {[\
][reduce [info frame 0]]} ; # 1741
} "type source line [expr {$offset + 1741}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.33 {TIP 280 for compiled [subst]} {
subst {[
][reduce [info frame 0]]} ; # 1745
} "type source line [expr {$offset + 1745}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.34 {TIP 280 for compiled [subst]} {
subst {[format %s {}
][reduce [info frame 0]]} ; # 1749
} "type source line [expr {$offset + 1749}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.35 {TIP 280 for compiled [subst]} {
subst {[format %s {}
]
[reduce [info frame 0]]} ; # 1754
} "
type source line [expr {$offset + 1754}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.36 {TIP 280 for compiled [subst]} {
subst {
[format %s {}][reduce [info frame 0]]} ; # 1759
} "
type source line [expr {$offset + 1759}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.37 {TIP 280 for compiled [subst]} {
subst {
[format %s {}]
[reduce [info frame 0]]} ; # 1765
} "
type source line [expr {$offset + 1765}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.38 {TIP 280 for compiled [subst]} {
subst {\
[format %s {}][reduce [info frame 0]]} ; # 1771
} " type source line [expr {$offset + 1771}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.39 {TIP 280 for compiled [subst]} {
subst {\
[format %s {}]\
[reduce [info frame 0]]} ; # 1776
} " type source line [expr {$offset + 1776}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.40 {TIP 280 for compiled [subst]} -setup {
unset -nocomplain empty
} -body {
set empty {}
subst {$empty[reduce [info frame 0]]} ; # 1782
} -cleanup {
unset empty
} -result "type source line [expr {$offset + 1782}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.41 {TIP 280 for compiled [subst]} -setup {
unset -nocomplain empty
} -body {
set empty {}
subst {$empty
[reduce [info frame 0]]} ; # 1791
} -cleanup {
unset empty
} -result "
type source line [expr {$offset + 1791}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.42 {TIP 280 for compiled [subst]} -setup {
unset -nocomplain empty
} -body {
set empty {}; subst {$empty\
[reduce [info frame 0]]} ; # 1800
} -cleanup {
unset empty
} -result " type source line [expr {$offset + 1800}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.43 {TIP 280 for compiled [subst]} -body {
unset -nocomplain a\nb
set a\nb {}
subst {${a
b}[reduce [info frame 0]]} ; # 1808
} -cleanup {unset a\nb} -result "type source line [expr {$offset + 1808}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.44 {TIP 280 for compiled [subst]} {
unset -nocomplain a
set a(\n) {}
subst {$a(
)[reduce [info frame 0]]} ; # 1814
} "type source line [expr {$offset + 1814}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.45 {TIP 280 for compiled [subst]} {
unset -nocomplain a
set a() {}
subst {$a([
return -level 0])[reduce [info frame 0]]} ; # 1820
} "type source line [expr {$offset + 1820}] file info.test cmd {info frame 0} proc ::tcltest::RunTest"
test info-30.46 {TIP 280 for compiled [subst]} {
unset -nocomplain a
set a([expr {$offset + 1825}]) YES; set a([expr {$offset + 1824}]) [expr {$offset + 1824}]; set a([expr {$offset + 1826}]) [expr {$offset + 1826}]
subst {$a([dict get [info frame 0] line])} ; # 1825
} YES
test info-30.47 {TIP 280 for compiled [subst]} {
unset -nocomplain a
set a(\n[expr {$offset + 1831}]) YES; set a(\n[expr {$offset + 1830}]) 1830; set a(\n[expr {$offset + 1832}]) [expr {$offset + 1832}]
subst {$a(
[dict get [info frame 0] line])} ; # 1831
} YES
unset -nocomplain a
test info-30.48 {Bug 2850901} testevalex {
testevalex {return -level 0 [format %s {}
][reduce [info frame 0]]} ; # line 2 of the eval
} "type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest"
# -------------------------------------------------------------------------
# literal sharing 2, bug 2933089
test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup {
set result {}
|
| ︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 |
test_info_frame;
join $result \n
} -cleanup {
trace remove execution print_one enter get_frame_info
rename get_frame_info {}
rename test_info_frame {}
rename print_one {}
| | | | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 |
test_info_frame;
join $result \n
} -cleanup {
trace remove execution print_one enter get_frame_info
rename get_frame_info {}
rename test_info_frame {}
rename print_one {}
} -result "type source line [expr {$offset + 1854}] file info.test cmd print_one proc ::test_info_frame level 1
type source line [expr {$offset + 1859}] file info.test cmd print_one proc ::test_info_frame level 1"
# -------------------------------------------------------------------------
# Tests moved to the end to not disturb other tests and their locations.
test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body {
interp eval sub {
proc etrace {} {
|
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 |
control y {
set y PPL
etrace
}
}
join [lrange [datal] 0 4] \n
}
| | | | | | | 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 |
control y {
set y PPL
etrace
}
}
join [lrange [datal] 0 4] \n
}
} -result "* {type source line [expr {$offset + 1890}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type source line [expr {$offset + 1902}] file info.test cmd etrace proc ::control}
* {type source line [expr {$offset + 1897}] file info.test cmd {uplevel 1 \$script} proc ::control}
* {type source line [expr {$offset + 1900}] file info.test cmd control proc ::datal level 1}
* {type source line [expr {$offset + 1905}] file info.test cmd datal level 2}" -cleanup {interp delete sub}
test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body {
interp eval sub {
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
|
| ︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 |
return [uplevel 1 $script]
}
join [lrange [control y {
set y DPL
etrace
}] 0 3] \n
}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
return [uplevel 1 $script]
}
join [lrange [control y {
set y DPL
etrace
}] 0 3] \n
}
} -result "* {type source line [expr {$offset + 1919}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type source line [expr {$offset + 1930}] file info.test cmd etrace proc ::control}
* {type source line [expr {$offset + 1926}] file info.test cmd {uplevel 1 \$script} proc ::control}
* {type source line [expr {$offset + 1928}] file info.test cmd control level 1}" -cleanup {interp delete sub}
test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body {
interp eval sub {
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
join [lrange [uplevel \#0 {
set y DL.
etrace
}] 0 2] \n
}
} -result "* {type source line [expr {$offset + 1944}] file info.test cmd {info frame \$level} proc ::etrace level 0}
* {type source line [expr {$offset + 1951}] file info.test cmd etrace level 1}
* {type source line [expr {$offset + 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"}
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
catch {*}{
{info frame 0}
res
}
return $res
}
test info-33.4 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 1968}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
dict for {a b} {c d} {*}{
{set res [info frame 0]}
}
return $res
}
test info-33.5 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 1983}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set d {a b}
dict update d x y {*}{
{set res [info frame 0]}
}
return $res
}
test info-33.6 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 1998}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set d {}
dict with d {*}{
{set res [info frame 0]}
}
return $res
}
test info-33.7 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2013}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
for {*}{
{set res [info frame 0]}
{1} {} {break}
}
return $res
}
test info-33.8 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2027}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
for {*}{
{} {1} {}
{set res [info frame 0]; break}
}
return $res
}
test info-33.9 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2043}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
for {*}{
{} {1}
{return [info frame 0]}
{}
}
}
test info-33.10 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2058}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
for {*}{
{}
{[return [info frame 0]]}
{} {}
}
}
test info-33.11 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2073}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
foreach {*}{
x
} [return [info frame 0]] {}
}
test info-33.12 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2088}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
foreach {*}{
x y
{set res [info frame 0]}
}
return $res
}
test info-33.13 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2101}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
if {*}{
{[return [info frame 0]]}
{}
}
}
test info-33.14 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2115}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
if 0 {*}{
{} else
{return [info frame 0]}
}
}
test info-33.15 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2130}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
incr {*}{
x
} [return [info frame 0]]
}
test info-33.16 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2144}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
info level {*}{
} [return [info frame 0]]
}
test info-33.17 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2156}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
string match {*}{
} [return [info frame 0]] {}
}
test info-33.18 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2168}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
string match {*}{
{}
} [return [info frame 0]]
}
test info-33.19 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2181}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
string length {*}{
} [return [info frame 0]]
}
test info-33.20 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2193}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
while {*}{
{[return [info frame 0]]}
} {}
}
test info-33.21 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2205}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
switch -- {*}{
} [return [info frame 0]] {*}{
} x y
}
test info-33.22 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2218}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {*}{
{set res [info frame 0]}
}
return $res
}
test info-33.23 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2231}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {*}{
{set res [info frame 0]}
} finally {}
return $res
}
test info-33.24 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2245}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {*}{
{set res [info frame 0]}
} on ok {} {}
return $res
}
test info-33.25 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2259}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {*}{
{set res [info frame 0]}
} on ok {} {} finally {}
return $res
}
test info-33.26 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2273}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
while 1 {*}{
{return [info frame 0]}
}
}
test info-33.27 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2287}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {} finally {*}{
{return [info frame 0]}
}
}
test info-33.28 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2300}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {} on ok {} {} finally {*}{
{return [info frame 0]}
}
}
test info-33.29 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2313}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {} on ok {} {*}{
{return [info frame 0]}
}
}
test info-33.30 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2326}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
try {} on ok {} {*}{
{return [info frame 0]}
} finally {}
}
test info-33.31 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2339}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
binary format {*}{
} [return [info frame 0]]
}
test info-33.32 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2352}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
set format format
binary $format {*}{
} [return [info frame 0]]
}
test info-33.33 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2365}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
append x {*}{
} [return [info frame 0]]
}
test info-33.34 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2377}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval foo {}
proc foo::bar {} {
append {*}{
} x([return [info frame 0]]) {*}{
} a
}
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
} -result "type source line [expr {$offset + 2389}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace eval ::testinfocmdtype {
apply {cmds {
foreach c $cmds {rename $c {}}
} ::testinfocmdtype} [info commands ::testinfocmdtype::*]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
|
| ︙ | ︙ |
1 2 3 4 5 | # This file contains internal facilities for Tcl tests. # # Source this file in the related tests to include from tcl-tests: # # source [file join [file dirname [info script]] internals.tcl] | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2020 Sergey G. Brester (sebres).
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains internal facilities for Tcl tests.
#
# Source this file in the related tests to include from tcl-tests:
#
# source [file join [file dirname [info script]] internals.tcl]
if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals {
namespace path ::tcltest
::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} }
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the multiple interpreter facility of Tcl
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
3340 3341 3342 3343 3344 3345 3346 |
after 100
log 2
}
} msg
interp delete $i
lappend result $msg
} -result {1 {time limit exceeded}}
| | | 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 |
after 100
log 2
}
} msg
interp delete $i
lappend result $msg
} -result {1 {time limit exceeded}}
test interp-34.11 {time limit extension in callbacks} -setup {
proc cb1 {i args} {
global result
lappend result cb1
$i limit time {*}[_ms_limit_args {*}$args] -command cb2
}
proc cb2 {} {
global result
|
| ︙ | ︙ |
|
| < < < < < < < < > > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
| | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} testchannel {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line]
|
| ︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
} 160
| | | < < < | < | < < < < < | > | | | | | | > > > > > | > | > > > > | > | | > | < < | < < | < < | > | > > > > | > > | | | > > > > > > > > > > > > > > > > > > > > > | 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 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
} 160
apply [list {} {
set template {
test {io-12.9 @variant@} {ReadChars: multibyte chars split, default (strict)} -body {
set res {}
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
close $f
set f [open $path(test1)]
fconfigure $f -encoding utf-8 @strict@ -buffersize 10
set status [catch {read $f} cres copts]
if {$status} {
if {[dict exists $copts -result read]} {
set in [dict get $copts -result read]
} else {
set in {}
}
} else {
set in $cres
}
lappend res $in
lappend res $status $cres
set scan [scan [string index $in end] %c]
lappend res $scan
set status [catch {read $f} cres copts]
if {$status} {
if {[dict exists $copts -result read]} {
set in [dict get $copts -result read]
} else {
set in {}
}
} else {
set in $cres
}
lappend res $in
lappend res $status $cres
set scan [scan [string index $in end] %c]
lappend res $scan
set res
} -cleanup {
catch {close $f}
} -match glob -result @result@
}
set errorres {aaaaaaaaa 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 97\
{} 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} {}}
# if default encoding is not currently to strict
# foreach variant {default encodingstrict} strict {{} {-encodingstrict 1}}
foreach variant {
{profile default} {profile strict} {profile tcl8}
} strict {{} {-profile strict} {-profile tcl8}} result [list \
$errorres $errorres [
list aaaaaaaaa\xC2 0 aaaaaaaaa\xC2 194 {} 0 {} {}]
] {
set script [string map [
list @result@ [list $result] @variant@ $variant @strict@ $strict] $template]
uplevel 1 $script
}
} [namespace current]]
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef\r"
close $f
set f [open $path(test1)]
|
| ︙ | ︙ | |||
2466 2467 2468 2469 2470 2471 2472 |
test io-28.6 {
close channel in write event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
| | < < > | > | < < < < < < | < < | > | < < | | | | | | 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 |
test io-28.6 {
close channel in write event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} debugpurify {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
# just enough of a refchan for the purpose of the test
set chan [chan create w {apply {{cmd chan args} {
switch $cmd {
initialize {
list initialize finalize watch write configure blocking
}
watch {
chan postevent $chan write
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan writable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} success
test io-28.7 {
close channel in read event handler
Should not produce a segmentation fault in a Tcl built with
--enable-symbols and -DPURIFY
} debugpurify {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
set chan [chan create r {apply {{cmd chan args} {
switch $cmd {
blocking - finalize {
}
watch {
chan postevent $chan read
}
initialize {
list initialize finalize watch read write configure blocking
}
default {
error [list {unexpected command} $cmd]
}
}
}}}]
chan configure $chan -blocking 0
while 1 {
chan event $chan readable [list [info coroutine]]
yield
close $chan
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
return success
} success
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
|
| ︙ | ︙ | |||
5844 5845 5846 5847 5848 5849 5850 |
update
fconfigure $s2 -translation {auto auto}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
| | | | 5867 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 |
update
fconfigure $s2 -translation {auto auto}
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} -constraints unix -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l ""
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar {O {}}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
} -result {{} O D}
test io-39.22a {Tcl_SetChannelOption, invariance} -body {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l [list]
fconfigure $f1 -eofchar {O {}}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
|
| ︙ | ︙ | |||
6232 6233 6234 6235 6236 6237 6238 |
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
| < < < | | < < < | < < < | | | < < | | < < < < < < < < | | | < < < < < < < | > | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 |
set x
} -cleanup {
close $f4
} -result {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
proc finalize {chan args} {
namespace delete c_$chan
}
proc initialize {chan args} {
namespace eval c_$chan {}
namespace upvar c_$chan watching watching
set watching {}
list finalize initialize seek watch write
}
proc watch {chan args} {
namespace upvar c_$chan watching watching
foreach arg $args {
switch $arg {
write {
if {$arg ni $watching} {
lappend watching $arg
}
chan postevent $chan $arg
}
}
}
}
proc write {chan args} {
chan postevent $chan write
return 1
}
}
set f [chan create w [namespace which refchan]]
chan configure $f -blocking 0
set data "some data"
set x 0
chan event $f writable [namespace code {
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
set token [after 10000 [namespace code {
set x timeout
}]]
vwait [namespace which -variable x]
return $x
} -cleanup {
after cancel $token
catch {chan close $f}
} -result done
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
|
| ︙ | ︙ | |||
7392 7393 7394 7395 7396 7397 7398 |
close $f3
string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
| | | | | > | | | > | | 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 |
close $f3
string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -encoding utf-8 -translation cr -encoding iso8859-1 -blocking 0
set s0 [fcopy $f1 $f2]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -blocking 0
fconfigure $f2 -encoding utf-8 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
# the file size is 41 because "©" is encoded in two bytes
lappend result [file size $path(test1)]
} {0 0 0 41}
test io-52.4.1 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -encoding utf-8 -translation lf -blocking 0 -buffersize 10000000
fconfigure $f2 -encoding utf-8 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
# the file size is 41 because "©" is encoded in two bytes
lappend result [file size $path(test1)]
} {0 0 0 41}
test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
|
| ︙ | ︙ | |||
7523 7524 7525 7526 7527 7528 7529 |
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
| | | > | | 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 |
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
fconfigure \$f1 -encoding utf-8 -translation lf
puts \[read \$f1 100\]
close \$f1
"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open $path(test1) w]
fconfigure $f2 -encoding utf-8 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
# the file size is 41 because "©" is encoded in two bytes
list $s0 [file size $path(test1)]
} {40 41}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
|
| ︙ | ︙ | |||
7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 |
fconfigure $out -encoding koi8-r -translation lf
fcopy $in $out
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy} -body {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 |
fconfigure $out -encoding koi8-r -translation lf
fcopy $in $out
} -cleanup {
close $in
close $out
} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
test io-52.20.1 {TclCopyChannel & read encoding error & tell position, bug [a173f9229]} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy knownBug} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# Using "-encoding ascii" means reading the "Á" gives an error
fconfigure $in -encoding ascii -profile strict
fconfigure $out -encoding koi8-r -translation lf
set l {}
# should fail, so 1 is added
lappend l [catch {fcopy $in $out}]
# should be at position 1, after the first correct byte, so 1 is read.
lappend l [tell $in]
# not sure, if flush required, but anyway
flush $out
# should be at position 1, after the first correct byte, so 1 is written.
lappend l [tell $out]
} -cleanup {
close $in
close $out
} -returnCodes 0 -result {1 1 1}
test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
puts $out "AÁ"
close $out
} -constraints {fcopy} -body {
|
| ︙ | ︙ | |||
9395 9396 9397 9398 9399 9400 9401 |
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
| > > > > > > > > > > > > > > > > > > > > | > > | 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 |
binary scan $d H* hd
set hd
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
test io-75.6.read {invalid utf-8 encoding, read is not ignored (-encodingstrict 1)} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf \
-profile strict
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
binary scan $d H* hd
lappend hd $status $cres
} -cleanup {
close $f
removeFile io-75.6
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.6.gets {invalid utf-8 encoding, gets is not ignored (-profile strict)} -setup {
set fn [makeFile {} io-75.6]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is an incomplete byte sequence in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
|
| ︙ | ︙ | |||
9491 9492 9493 9494 9495 9496 9497 |
gets $f
} -cleanup {
close $f
removeFile io-75.6.4
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
| | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 |
gets $f
} -cleanup {
close $f
removeFile io-75.6.4
} -match glob -returnCodes 1 -result {error reading "file*":\
invalid or incomplete multibyte or wide character}
test io-75.7.gets {
invalid utf-8 encoding gets is not ignored (-profile strict)
} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
-profile strict
} -body {
list [catch {gets $f} msg] $msg
} -cleanup {
close $f
removeFile io-75.7
unset msg f fn
} -match glob -result {1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.7.read {
invalid utf-8 encoding read is not ignored (-profile strict)
} -setup {
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -translation lf \
-profile strict
} -body {
list [catch {read $f} msg data] $msg [dict get $data -result read]
} -cleanup {
close $f
removeFile io-75.7
unset msg data f fn
} -match glob -result {1 {error reading "file*":\
invalid or incomplete multibyte or wide character} A}
test {io-75.8 {invalid input before eof}} {invalid utf-8 before eof (-profile strict)} -setup {
set hd {}
set fn [makeFile {} io-75.7]
set f [open $fn w+]
fconfigure $f -translation binary
# \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later.
puts -nonewline $f A\xA1\x1A
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set status [catch {read $f} cres copts]
if {[dict exists $copts -result read]} {
set d [dict get $copts -result read]
} else {
set d {}
}
binary scan $d H* hd
lappend hd [eof $f]
lappend hd $status
lappend hd $cres
fconfigure $f -encoding iso8859-1
lappend hd [read $f];# We changed encoding, so now we can read the \xA1
close $f
set hd
} -cleanup {
removeFile io-75.7
} -match glob -result {41 0 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} ¡}
test {io-75.8 {incomplete input after eof}} {
incomplete utf-8 char after eof char is not an error (-profile strict)
} -setup {
set hd {}
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8, but since the eof character \x1A comes first,
# -eofchar takes precedence.
puts -nonewline $f A\x1A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [eof $f]
# there should be no error on additional reads
lappend hd [read $f]
set hd
} -cleanup {
close $f
removeFile io-75.8
unset f d hd
} -result {41 1 {}}
test {io-75.8 {invalid input after eof}} {
invalid utf-8 after eof char is not an error (-profile strict)
} -setup {
set res {}
set fn [makeFile {} io-75.8]
set f [open $fn w+]
fconfigure $f -translation binary
# \xc0\x80 is invalid utf-8 data, but because the eof character \x1A
# appears first, it's not an error.
puts -nonewline $f A\x1a\xc0\x80
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set d [read $f]
foreach char [split $d {}] {
lappend res [format %x [scan $char %c]]
}
lappend res [eof $f]
# there should be no error on additional reads
lappend res [read $f]
close $f
set res
} -cleanup {
removeFile io-75.8
} -result {41 1 {}}
test {io-75.8 {invalid input before eof}} {
invalid utf-8 encoding eof handling (-profile strict)
} -setup {
set fn [makeFile {} io-75.8]
set f [open $fn w+]
# This also configures the channel encoding profile as strict.
fconfigure $f -translation binary
# \x81 is invalid in utf-8. -eofchar is not detected, because it comes later.
puts -nonewline $f A\x81\x81\x1A
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
set res [list [catch {read $f} msg data] [eof $f]]
if {[dict exists $data -result read]} {
lappend res [dict get $data -result read]
} else {
lappend res {}
}
chan configure $f -encoding iso8859-1
lappend res [read $f 1]
chan configure $f -encoding utf-8
lappend res [catch {read $f 1} msg data] $msg
if {[dict exists $data -result read]} {
lappend res [dict get $data -result read]
} else {
lappend res {}
}
return $res
} -cleanup {
close $f
removeFile io-75.8
unset res msg data fn f
} -match glob -result "1 0 A \x81 1 {error reading \"*\":\
invalid or incomplete multibyte or wide character} {}"
test io-strict-multibyte-eof {
incomplete utf-8 sequence immediately prior to eof character
See issue 25cdcb7e8fb381fb
} -setup {
set chan [file tempfile];
fconfigure $chan -translation binary
puts -nonewline $chan \x81\x1A
flush $chan
seek $chan 0
chan configure $chan -encoding utf-8 -profile strict
} -body {
list [catch {read $chan 1} msg data] $msg [if {
[dict exists $data -result read]
} {
dict get $data -result read
} else {
lindex {}
}
]
} -cleanup {
close $chan
unset msg chan data
} -match glob -result {1 {error reading "*":\
invalid or incomplete multibyte or wide character} {}}
test io-75.9 {unrepresentable character write throws error in strict profile} -setup {
set fn [makeFile {} io-75.9]
set f [open $fn w+]
fconfigure $f -encoding iso8859-1 -profile strict
} -body {
catch {puts -nonewline $f "A\u2022"} msg
flush $f
seek $f 0
list [read $f] $msg
} -cleanup {
close $f
removeFile io-75.9
unset f
} -match glob -result [list {A} {error writing "*":\
invalid or incomplete multibyte or wide character}]
apply [list {} {
set template {
test {io-75.10 ${mode}} {
incomplete multibyte encoding read is an error
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\xC0
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none {*}${option}
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
close $f
binary scan $d H* hd
lappend res $hd
lappend res $status
lappend res $cres
return $res
} -cleanup {
removeFile io-75.10
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
}
# the default encoding mode is not currently strict
#foreach mode {default strict} option {{} {-encodingstrict 1}}
foreach mode {{profile strict}} option {{-profile strict}} {
set test [string map [
list {${mode}} [list $mode] {${option}} [list $option]] $template]
uplevel $test
}
} [namespace current]]
test {io-75.10 {profile tcl8}} {
incomplete multibyte encoding read is not ignored because "binary" sets
profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.10]
set f [open $fn w+]
fconfigure $f -translation binary
|
| ︙ | ︙ | |||
9642 9643 9644 9645 9646 9647 9648 |
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
| | > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 |
flush $f
seek $f 0
fconfigure $f -encoding shiftjis -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {set d [read $f]} msg data] $msg [
dict exists $data -result read]
} -cleanup {
close $f
removeFile io-75.11
unset d hd msg data f
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 0}
apply [list {} {
set template {
test {io-75.12 ${mode}} {
invalid utf-8 encoding read returns an error
} -setup {
set res {}
set fn [makeFile {} io-75.12]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
-translation lf {*}${option}
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
close $f
binary scan $d H* hd
lappend res $hd $status $cres
return $res
} -cleanup {
removeFile io-75.12
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
}
# the default encoding mod is not currently strict
#foreach mode {default strict} option {{} {-encodingstrict 1}}
foreach mode {{profile strict}} option {{-profile strict}} {
set test [string map [
list {${mode}} [list $mode] {${option}} [list $option]] $template]
uplevel $test
}
} [namespace current]]
test {io-75.12 {profile tcl8}} {
invalid utf-8 encoding read, is not ignored because setting the encoding to
"binary" also sets the profile to strict
} -setup {
set res {}
set fn [makeFile {} io-75.12]
set f [open $fn w+]
fconfigure $f -translation binary
puts -nonewline $f A\x81
flush $f
|
| ︙ | ︙ | |||
9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 |
} -cleanup {
close $f
removeFile io-75.12
unset res
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 4181}
test io-75.13 {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
| > > > > > > > > > > > > > > > > > > > > > > > | | 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 |
} -cleanup {
close $f
removeFile io-75.12
unset res
} -match glob -result {{error reading "file*":\
invalid or incomplete multibyte or wide character} 4181}
test io-75.13 {
In blocking mode [read] produces an error and leaves the data succesfully
read so far in the return options dictionary.
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -eofchar "" -translation lf -profile strict
} -body {
set status [catch {read $f} cres copts]
set d [dict get $copts -result read]
binary scan $d H* hd
lappend hd $status
lappend hd $cres
} -cleanup {
close $f
removeFile io-75.13
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character}}
test io-75.13.nonblocking {
In nonblocking mode when there is an encoding error the data that has been
successfully read so far is returned first and then the error is returned
on the next call to [read].
} -setup {
set fn [makeFile {} io-75.13]
set f [open $fn w+]
fconfigure $f -translation binary
# \x81 is invalid in utf-8
puts -nonewline $f A\x81
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -blocking 0 -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
lappend hd [catch {read $f} msg data] $msg [dict exists $data -result read]
} -cleanup {
close $f
removeFile io-75.13
unset d hd msg data f fn
} -match glob -result {41 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 0}
|
| ︙ | ︙ | |||
9718 9719 9720 9721 9722 9723 9724 |
flush $chan
seek $chan 0
fconfigure $chan -encoding utf-8 -buffering none \
-translation auto -profile strict
} -body {
set res [gets $chan]
lappend res [gets $chan]
| | > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 |
flush $chan
seek $chan 0
fconfigure $chan -encoding utf-8 -buffering none \
-translation auto -profile strict
} -body {
set res [gets $chan]
lappend res [gets $chan]
lappend res [catch {gets $chan} msg data] $msg [
if {[dict exists $data -result read]} {
dict get $data -result read
} else {
lindex {}
}
]
chan configure $chan -profile tcl8
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
unset chan res msg data
} -match glob -result {a b 1 {error reading "*":\
invalid or incomplete multibyte or wide character} {} cÀ d}
test io-75.15 {
invalid utf-8 encoding strict
gets does not hang
gets succeeds for the first two lines
} -setup {
set res {}
set chan [file tempfile]
fconfigure $chan -translation binary
# \xC0\x40 is an invalid utf-8 sequence
puts $chan hello\nAB\nCD\xC0\x40EF\nGHI
seek $chan 0
} -body {
#Now try to read it with [gets]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
lappend res [gets $chan]
lappend res [catch {gets $chan} msg data] $msg [dict exists $data -result read]
lappend res [catch {gets $chan} msg data] $msg [dict exists $data -result read]
chan configure $chan -translation binary
set data [read $chan 4]
foreach char [split $data {}] {
scan $char %c ord
lappend res [format %x $ord]
}
fconfigure $chan -encoding utf-8 -profile strict -translation auto
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
unset chan res msg data
} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI}
test io-75.14 {invalid utf-8 encoding [gets] continues in non-strict mode after error} -setup {
set res {}
set fn [makeFile {} io-75.14]
set f [open $fn w+]
fconfigure $f -translation binary
# \xc0 is invalid in utf-8
puts -nonewline $f a\nb\xc0\nc\n
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf -profile strict
} -body {
lappend res [gets $f]
set status [catch {gets $f} cres copts]
lappend res $status $cres
chan configure $f -profile tcl8
lappend res [gets $f]
lappend res [gets $f]
close $f
return $res
} -cleanup {
removeFile io-75.14
} -match glob -result {a 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} bÀ c}
test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup {
set res {}
set fn [makeFile {} io-75.15]
set chan [open $fn w+]
fconfigure $chan -translation binary
# This is not valid UTF-8
puts $chan hello\nAB\xc0\x40CD\nEFG
close $chan
} -body {
#Now try to read it with [gets]
set chan [open $fn]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
set status [catch {gets $chan} cres copts]
lappend res $status $cres
set status [catch {gets $chan} cres copts]
lappend res $status $cres
lappend res [
if {[dict exists $copts -result read]} {
dict get $copts -result read
} else {
lindex {}
}
]
chan configure $chan -translation binary
foreach char [split [read $chan 2] {}] {
lappend res [format %x [scan $char %c]]
}
return $res
} -cleanup {
close $chan
removeFile io-75.15
} -match glob -result {hello 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} 1 {error reading "file*":\
invalid or incomplete multibyte or wide character} {} 41 42}
# ### ### ### ######### ######### #########
test io-76.0 {channel modes} -setup {
set datafile [makeFile {some characters} dummy]
|
| ︙ | ︙ | |||
9886 9887 9888 9889 9890 9891 9892 |
testchannel mremove-rd $f
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 |
testchannel mremove-rd $f
testchannel mremove-wr $f
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
# cleanup
foreach file [list fooBar longfile script2 output test1 pipe my_script \
test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
|
|
| < < < < < < < < < > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
# fblocked, fconfigure, open, channel, fcopy,
# readFile, writFile, foreachLine
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
| > > > > > > > > > > > | 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 |
return -code return $args
}
proc onfinal {} {
upvar args hargs
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
proc onwatch {} {
upvar args hargs
lassign $hargs watch chan eventspec
if {$watch ne "watch"} return
foreach spec $eventspec {
chan postevent $chan $spec
}
return
}
}
# Set everything up in the main thread.
eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
|
| ︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 |
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
| | | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 |
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
proc foo args {oninit cget cgetall; onfinal; track; return {}}
set c [chan create {r w} foo]
note [fconfigure $c]
close $c
rename foo {}
set res
} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -profile * -translation {auto *}}}
test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body {
|
| ︙ | ︙ | |||
2044 2045 2046 2047 2048 2049 2050 |
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
| | | > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
note [fileevent $c writable {lappend res TOCK; set tock 1}]
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
proc foo {args} {oninit; onfinal; track; return}
proc dummy args { return }
set c [chan create {r w} foo]
fileevent $c readable dummy
} -body {
close $c
chan postevent $c read
} -cleanup {
rename foo {}
rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
chan postevent
call to current coroutine
see 67a5eabbd3d1
} -match glob -body {
set res {}
proc foo {args} {oninit; onwatch; onfinal; track; return}
set c [chan create {r w} foo]
after 0 [list ::apply [list c {
coroutine c1 ::apply [list c {
chan event $c readable [list [info coroutine]]
yield
set ::done READING
} [namespace current]] $c
} [namespace current]] $c]
set stop [after 10000 {set done TIMEOUT}]
vwait ::done
catch {after cancel $stop}
lappend res $done
close $c
rename foo {}
set res
} -result {{watch rc* read} READING {watch rc* {}}}
# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.
test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
| ︙ | ︙ |
|
| < < < < < < < > > > > > > > > > > > > > | 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 © 2007 Andreas Kupries <andreask@activestate.com>
# <akupries@shaw.ca>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: operation of the reflected transformation
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| | | | | | | > > > > | > > > | 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 © 2000 Ajuba Solutions.
# Copyright © 2000 Andreas Kupries.
#
# All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: transform, and stacking in general
#
# This file contains a collection of tests for Giot
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: join
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test join-1.1 {basic join commands} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lindex
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains a collection of tests for Tcl_LinkVar and related library
# procedures. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < | > > > > > > > > > | | | | | | | | | | | | | | | | | < < < | > > > | | | | | | | | | | | | | | > | | | | | | | | | | | | > > > > > > > > > | | > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: linsert
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
proc newlist list {
return $list
}
variable tests {
foreach map {
{
@mode@ compiled
@linsert@ linsert
}
{
@mode@ uncompiled
@linsert@ {[lindex linsert]}
}
} {
set script [string map $map {
catch {unset lis}
catch {rename p ""}
test linsert-1.1-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 0 a
} {a 1 2 3 4 5}
test linsert-1.2-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 1 a
} {1 a 2 3 4 5}
test linsert-1.3-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 2 a
} {1 2 a 3 4 5}
test linsert-1.4-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 3 a
} {1 2 3 a 4 5}
test linsert-1.5-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 4 a
} {1 2 3 4 a 5}
test linsert-1.6-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 5 a
} {1 2 3 4 5 a}
test linsert-1.7-@mode@ {linsert command} {
@linsert@ [newlist {1 2 3 4 5}] 2 one two \{three \$four
} {1 2 one two \{three {$four} 3 4 5}
test linsert-1.8-@mode@ {linsert command} {
@linsert@ [newlist {\{one \$two \{three \ four \ five}] 2 a b c
} {\{one {$two} a b c \{three { four} { five}}
test linsert-1.9-@mode@ {linsert command} {
@linsert@ [newlist {{1 2} {3 4} {5 6} {7 8}}] 2 {x y} {a b}
} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}}
test linsert-1.10-@mode@ {linsert command} {
@linsert@ [newlist {}] 2 a b c
} {a b c}
test linsert-1.11-@mode@ {linsert command} {
@linsert@ [newlist {}] 2 {}
} {{}}
test linsert-1.12-@mode@ {linsert command} {
@linsert@ [newlist {a b "c c" d e}] 3 1
} {a b {c c} 1 d e}
test linsert-1.13-@mode@ {linsert command} {
@linsert@ [newlist { a b c d}] 0 1 2
} {1 2 a b c d}
test linsert-1.14-@mode@ {linsert command} {
@linsert@ [newlist {a b c {d e f}}] 4 1 2
} {a b c {d e f} 1 2}
test linsert-1.15-@mode@ {linsert command} {
@linsert@ [newlist {a b c \{\ abc}] 4 q r
} {a b c \{\ q r abc}
test linsert-1.16-@mode@ {linsert command} {
@linsert@ [newlist {a b c \{ abc}] 4 q r
} {a b c \{ q r abc}
test linsert-1.17-@mode@ {linsert command} {
@linsert@ [newlist {a b c}] end q r
} {a b c q r}
test linsert-1.18-@mode@ {linsert command} {
@linsert@ [newlist {a}] end q r
} {a q r}
test linsert-1.19-@mode@ {linsert command} {
@linsert@ [newlist {}] end q r
} {q r}
test linsert-1.20-@mode@ {linsert command, use of end-int index} {
@linsert@ [newlist {a b c d}] end-2 e f
} {a b e f c d}
test linsert-2.1-@mode@ {linsert errors} {
list [catch @linsert@ [newlist msg]] $msg
} {1 {wrong # args: should be "linsert list index ?element ...?"}}
test linsert-2.2-@mode@ {linsert errors} {
list [catch {@linsert@ [newlist a] b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.3-@mode@ {linsert errors} {
list [catch {@linsert@ [newlist a] 12x 2} msg] $msg
} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.4-@mode@ {linsert errors} {
list [catch {@linsert@ [newlist \{] 12 2} msg] $msg
} {1 {unmatched open brace in list}}
test linsert-2.5-@mode@ {syntax (TIP 323)} {
@linsert@ [newlist {a b c}] 0
} [list a b c]
test linsert-2.6-@mode@ {syntax (TIP 323)} {
@linsert@ [newlist "a\nb\nc"] 0
} [list a b c]
test linsert-3.1-@mode@ {linsert won't modify shared argument objects} {
proc p {} {
set list "a b c"
@linsert@ [newlist $list] 1 "x y"
return "a b c"
}
p
} "a b c"
test linsert-3.2-@mode@ {linsert won't modify shared argument objects} {
catch {unset lis}
set lis [format "a \"%s\" c" "b"]
@linsert@ [newlist $lis] 0 [string length $lis]
} "7 a b c"
# cleanup
catch {unset lis}
catch {rename p ""}
}]
try $script
}
}
if {[info exists ::argv0] && [info script] eq $::argv0} {
try $tests
::tcltest::cleanupTests
return
}
|
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: list
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# First, a bunch of individual tests
|
| ︙ | ︙ |
1 2 3 4 5 6 | # Functionality covered: operation of the procedures in tclListObj.c that # implement the Tcl type manager for the list object type. # # 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. | > > > > > > > > > > > > > < < < < < < | 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 © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: operation of the procedures in tclListObj.c that
# implement the Tcl type manager for the list object type.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
testlistobj replace 1 1 [expr {$SIZE_MAX -1}] f
testlistobj get 1
} {a f}
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
testobj bug3598580
} 123
| > > > | > > > > > | | | > > > | | 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 |
testlistobj replace 1 1 [expr {$SIZE_MAX -1}] f
testlistobj get 1
} {a f}
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
testobj bug3598580
} 123
#this test
test listobj-11.2 {
Bug e58d7e19e9: Upwards compatibility of TclObjTypeHasProc() In the
unchained branch the lookup table is private, so the original version of
this test is not applicable. Instead, this test that TclStringCmp uses
StringIsEmpty if it is available.
} testobj {
set res {}
set l [testobj buge58d7e19e9 2]
# Since $l is a V1 objType, it's lengthProc will be accessed, but not its StringIsEmpty proc.
lappend res [llength $l] [expr {$l eq {}}]
set m [testobj buge58d7e19e9 3]
lappend res [llength $m] [after 1000][expr {$m eq {}}]
return $res
} {100 0 100 1}
# Stolen from dict.test
proc listobjmemcheck script {
set end [lindex [split [memory info] \n] 3 3]
for {set i 0} {$i < 5} {incr i} {
uplevel 1 $script
set tmp $end
|
| ︙ | ︙ |
|
| < < < > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Copyright © 2022 Ashok P. Nadkarni # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file contains tests that specifically exercise the internal representation # of a list. # Unlike the other files related to list commands which for the most part do # black box testing focusing on functionality, this file does more of white box # testing to exercise code paths that implement different list representations # (with spans, leading free space etc., shared/unshared etc.) In addition to # functional correctness, the tests also check for the expected internal # representation as that pertains to performance heuristics. Generally speaking, |
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: llength
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test llength-1.1 {length of list} {
|
| ︙ | ︙ |
|
| < < < < < < | > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 2011 Trevor Davel
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# RCS: @(#) $Id: $
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain a b i x
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: load
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lpop
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain no; # following tests expecting var "no" does not exists
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lrange
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: lrepeat # # 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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2003 Simon Geard.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lrepeat
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
## Arg errors
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lreplace
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test lreplace-1.1 {lreplace command} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lsearch
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set x {abcd bbcd 123 234 345}
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: lseq # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2003 Simon Geard.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lseq
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint arithSeriesDouble 1
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
unset r rep-before m rep-after rep-m
} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}}
test lseq-3.14 {array for shimmer} -constraints arithSeriesShimmerOk -body {
array set testarray {a Test for This great Function}
set vars [lseq 2]
set vars-rep [lindex [tcl::unsupported::representation $vars] 3]
array for $vars testarray {
lappend keys $0
lappend vals $1
}
# Since hash order is not guaranteed, have to validate content ignoring order
set valk [lmap k $keys {expr {$k in {a for great}}}]
set valv [lmap v $vals {expr {$v in {Test This Function}}}]
| > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
unset r rep-before m rep-after rep-m
} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}}
test lseq-3.14 {array for shimmer} -constraints arithSeriesShimmerOk -body {
array set testarray {a Test for This great Function}
set vars [lseq 2]
set vars-rep [lindex [tcl::unsupported::representation $vars] 3]
after 1
array for $vars testarray {
lappend keys $0
lappend vals $1
}
# Since hash order is not guaranteed, have to validate content ignoring order
set valk [lmap k $keys {expr {$k in {a for great}}}]
set valv [lmap v $vals {expr {$v in {Test This Function}}}]
|
| ︙ | ︙ |
|
| > > > > | > > > > > > < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | < < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > | 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 |
# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lset
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testevalex [llength [info commands testevalex]]
proc newlist list {
return $list
}
variable tests {
foreach map {
{
@mode@ compiled
@lset@ lset
}
{
@mode@ uncompiled
@lset@ {[lindex lset]}
}
} {
set script [string map $map {
proc failTrace {name1 name2 op} {
error "trace failed"
}
set noRead {}
trace add variable noRead read failTrace
set noWrite {a b c}
trace add variable noWrite write failTrace
test lset-1.1-@mode@ {lset, not compiled, arg count} testevalex {
list [catch {testevalex @lset@} msg] $msg
} "1 {wrong \# args: should be \"lset listVar ?index? ?index ...? value\"}"
test lset-1.2-@mode@ {lset, not compiled, no such var} testevalex {
list [catch {testevalex {@lset@ noSuchVar 0 {}}} msg] $msg
} "1 {can't read \"noSuchVar\": no such variable}"
test lset-1.3-@mode@ {lset, not compiled, var not readable} testevalex {
list [catch {testevalex {@lset@ noRead 0 {}}} msg] $msg
} "1 {can't read \"noRead\": trace failed}"
test lset-2.1-@mode@ {lset, not compiled, 3 args, second arg a plain index} testevalex {
set x {0 1 2}
list [testevalex {@lset@ x 0 3}] $x
} {{3 1 2} {3 1 2}}
test lset-2.2-@mode@ {lset, not compiled, 3 args, second arg neither index nor list} testevalex {
set x {0 1 2}
list [catch {
testevalex {@lset@ x {{bad}1} 3}
} msg] $msg
} {1 {bad index "{bad}1": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-3.1-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1 2}
list [testevalex {@lset@ x 0 $x}] $x
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}
test lset-3.2-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1}
set y $x
list [testevalex {@lset@ x 0 2}] $x $y
} {{2 1} {2 1} {0 1}}
test lset-3.3-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1}
set y $x
list [testevalex {@lset@ x 0 $x}] $x $y
} {{{0 1} 1} {{0 1} 1} {0 1}}
test lset-3.4-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1 2}
list [testevalex {@lset@ x [list 0] $x}] $x
} {{{0 1 2} 1 2} {{0 1 2} 1 2}}
test lset-3.5-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1}
set y $x
list [testevalex {@lset@ x [list 0] 2}] $x $y
} {{2 1} {2 1} {0 1}}
test lset-3.6-@mode@ {lset, not compiled, 3 args, data duplicated} testevalex {
set x {0 1}
set y $x
list [testevalex {@lset@ x [list 0] $x}] $x $y
} {{{0 1} 1} {{0 1} 1} {0 1}}
test lset-4.1-@mode@ {lset, not compiled, 3 args, not a list} testevalex {
set a "x \{"
list [catch {
testevalex {@lset@ a [list 0] y}
} msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.2-@mode@ {lset, not compiled, 3 args, bad index} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list 2a2] w}
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list -1] w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.4-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list 4] w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.5a-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list end--2] w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.5b-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list end+2] w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.6-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a [list end-3] w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-4.7-@mode@ {lset, not compiled, 3 args, not a list} testevalex {
set a "x \{"
list [catch {
testevalex {@lset@ a 0 y}
} msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.8-@mode@ {lset, not compiled, 3 args, bad index} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a 2a2 w}
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.9-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a -1 w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.10-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a 4 w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.11a-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a end--2 w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.11-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a end+2 w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.12-@mode@ {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {@lset@ a end-3 w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-5.1-@mode@ {lset, not compiled, 3 args, can't set variable} testevalex {
list [catch {
testevalex {@lset@ noWrite 0 d}
} msg] $msg $noWrite
} {1 {can't set "noWrite": trace failed} {d b c}}
test lset-5.2-@mode@ {lset, not compiled, 3 args, can't set variable} testevalex {
list [catch {
testevalex {@lset@ noWrite [list 0] d}
} msg] $msg $noWrite
} {1 {can't set "noWrite": trace failed} {d b c}}
test lset-6.1-@mode@ {lset, not compiled, 3 args, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a 0 a}] $a
} {{a y z} {a y z}}
test lset-6.2-@mode@ {lset, not compiled, 3 args, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a [list 0] a}] $a
} {{a y z} {a y z}}
test lset-6.3-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a 2 a}] $a
} {{x y a} {x y a}}
test lset-6.4-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a [list 2] a}] $a
} {{x y a} {x y a}}
test lset-6.5-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a end a}] $a
} {{x y a} {x y a}}
test lset-6.6-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a [list end] a}] $a
} {{x y a} {x y a}}
test lset-6.7-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a end-0 a}] $a
} {{x y a} {x y a}}
test lset-6.8-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a [list end-0] a}] $a
} {{x y a} {x y a}}
test lset-6.9-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a end-2 a}] $a
} {{a y z} {a y z}}
test lset-6.10-@mode@ {lset, not compiled, 1-d list basics} testevalex {
set a {x y z}
list [testevalex {@lset@ a [list end-2] a}] $a
} {{a y z} {a y z}}
test lset-7.1-@mode@ {lset, not compiled, data sharing} testevalex {
set a 0
list [testevalex {@lset@ a $a {gag me}}] $a
} {{{gag me}} {{gag me}}}
test lset-7.2-@mode@ {lset, not compiled, data sharing} testevalex {
set a [list 0]
list [testevalex {@lset@ a $a {gag me}}] $a
} {{{gag me}} {{gag me}}}
test lset-7.3-@mode@ {lset, not compiled, data sharing} testevalex {
set a {x y}
list [testevalex {@lset@ a 0 $a}] $a
} {{{x y} y} {{x y} y}}
test lset-7.4-@mode@ {lset, not compiled, data sharing} testevalex {
set a {x y}
list [testevalex {@lset@ a [list 0] $a}] $a
} {{{x y} y} {{x y} y}}
test lset-7.5-@mode@ {lset, not compiled, data sharing} testevalex {
set n 0
set a {x y}
list [testevalex {@lset@ a $n $n}] $a $n
} {{0 y} {0 y} 0}
test lset-7.6-@mode@ {lset, not compiled, data sharing} testevalex {
set n [list 0]
set a {x y}
list [testevalex {@lset@ a $n $n}] $a $n
} {{0 y} {0 y} 0}
test lset-7.7-@mode@ {lset, not compiled, data sharing} testevalex {
set n 0
set a [list $n $n]
list [testevalex {@lset@ a $n 1}] $a $n
} {{1 0} {1 0} 0}
test lset-7.8-@mode@ {lset, not compiled, data sharing} testevalex {
set n [list 0]
set a [list $n $n]
list [testevalex {@lset@ a $n 1}] $a $n
} {{1 0} {1 0} 0}
test lset-7.9-@mode@ {lset, not compiled, data sharing} testevalex {
set a 0
list [testevalex {@lset@ a $a $a}] $a
} {0 0}
test lset-7.10-@mode@ {lset, not compiled, data sharing} testevalex {
set a [list 0]
list [testevalex {@lset@ a $a $a}] $a
} {0 0}
test lset-8.1-@mode@ {lset, not compiled, malformed sublist} testevalex {
set a [list "a \{" b]
list [catch {testevalex {@lset@ a 0 1 c}} msg] $msg
} {1 {unmatched open brace in list}}
test lset-8.2-@mode@ {lset, not compiled, malformed sublist} testevalex {
set a [list "a \{" b]
list [catch {testevalex {@lset@ a {0 1} c}} msg] $msg
} {1 {unmatched open brace in list}}
test lset-8.3-@mode@ {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {@lset@ a 0 2a2 f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.4-@mode@ {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {@lset@ a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a 2 -1 h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.6-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a {2 -1} h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.7-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a 2 3 h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.8-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a {2 3} h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.9a-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a 2 end--2 h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.9b-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a 2 end+2 h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.10a-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a {2 end--2} h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.10b-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a {2 end+2} h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.11-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a 2 end-2 h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-8.12-@mode@ {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {@lset@ a {2 end-2} h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-9.1-@mode@ {lset, not compiled, entire variable} testevalex {
set a x
list [testevalex {@lset@ a y}] $a
} {y y}
test lset-9.2-@mode@ {lset, not compiled, entire variable} testevalex {
set a x
list [testevalex {@lset@ a {} y}] $a
} {y y}
test lset-10.1-@mode@ {lset, not compiled, shared data} testevalex {
set row {p q}
set a [list $row $row]
list [testevalex {@lset@ a 0 0 x}] $a
} {{{x q} {p q}} {{x q} {p q}}}
test lset-10.2-@mode@ {lset, not compiled, shared data} testevalex {
set row {p q}
set a [list $row $row]
list [testevalex {@lset@ a {0 0} x}] $a
} {{{x q} {p q}} {{x q} {p q}}}
test lset-10.3-@mode@ {lset, not compiled, shared data, [Bug 1333036]} testevalex {
set a [list [list p q] [list r s]]
set b $a
list [testevalex {@lset@ b {0 0} x}] $a
} {{{x q} {r s}} {{p q} {r s}}}
test lset-11.1-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a 0 0 f}] $a
} {{{f c} {d e}} {{f c} {d e}}}
test lset-11.2-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a {0 0} f}] $a
} {{{f c} {d e}} {{f c} {d e}}}
test lset-11.3-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a 0 1 f}] $a
} {{{b f} {d e}} {{b f} {d e}}}
test lset-11.4-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a {0 1} f}] $a
} {{{b f} {d e}} {{b f} {d e}}}
test lset-11.5-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a 1 0 f}] $a
} {{{b c} {f e}} {{b c} {f e}}}
test lset-11.6-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a {1 0} f}] $a
} {{{b c} {f e}} {{b c} {f e}}}
test lset-11.7-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a 1 1 f}] $a
} {{{b c} {d f}} {{b c} {d f}}}
test lset-11.8-@mode@ {lset, not compiled, 2-d basics} testevalex {
set a {{b c} {d e}}
list [testevalex {@lset@ a {1 1} f}] $a
} {{{b c} {d f}} {{b c} {d f}}}
test lset-12.0-@mode@ {lset, not compiled, typical sharing pattern} testevalex {
set zero 0
set row [list $zero $zero $zero $zero]
set ident [list $row $row $row $row]
for { set i 0 } { $i < 4 } { incr i } {
testevalex {@lset@ ident $i $i 1}
}
set ident
} {{1 0 0 0} {0 1 0 0} {0 0 1 0} {0 0 0 1}}
test lset-13.0-@mode@ {lset, not compiled, shimmering hell} testevalex {
set a 0
list [testevalex {@lset@ a $a $a $a $a {gag me}}] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
test lset-13.1-@mode@ {lset, not compiled, shimmering hell} testevalex {
set a [list 0]
list [testevalex {@lset@ a $a $a $a $a {gag me}}] $a
} {{{{{{gag me}}}}} {{{{{gag me}}}}}}
test lset-13.2-@mode@ {lset, not compiled, shimmering hell} testevalex {
set a [list 0 0 0 0]
list [testevalex {@lset@ a $a {gag me}}] $a
} {{{{{{gag me}}}} 0 0 0} {{{{{gag me}}}} 0 0 0}}
test lset-14.1-@mode@ {lset, not compiled, list args, is string rep preserved?} testevalex {
set a { { 1 2 } { 3 4 } }
catch { testevalex {@lset@ a {1 5} 5} }
list $a [lindex $a 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
test lset-14.2-@mode@ {lset, not compiled, flat args, is string rep preserved?} testevalex {
set a { { 1 2 } { 3 4 } }
catch { testevalex {@lset@ a 1 5 5} }
list $a [lindex $a 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
testConstraint testobj [llength [info commands testobj]]
test lset-15.1-@mode@ {lset: shared internalrep [Bug 1677512]} -setup {
teststringobj set 1 {{1 2} 3}
testobj convert 1 list
testobj duplicate 1 2
variable x [teststringobj get 1]
variable y [teststringobj get 2]
testobj freeallvars
set l [list $y z]
unset y
} -constraints testobj -body {
@lset@ l 0 0 0 5
lindex $x 0 0
} -cleanup {
unset -nocomplain x l
} -result 1
test lset-16.1-@mode@ {lset - grow a variable} testevalex {
set x {}
testevalex {@lset@ x 0 {test 1}}
testevalex {lset x 1 {test 2}}
set x
} {{test 1} {test 2}}
test lset-16.2-@mode@ {@lset@ - multiple created sublists} testevalex {
set x {}
testevalex {lset x 0 0 {test 1}}
} {{{test 1}}}
test lset-16.3-@mode@ {@lset@ - sublists 3 deep} testevalex {
set x {}
testevalex {lset x 0 0 0 {test 1}}
} {{{{test 1}}}}
test lset-16.4-@mode@ {@lset@ - append to inner list} testevalex {
set x {test 1}
testevalex {@lset@ x 1 1 2}
testevalex {@lset@ x 1 2 3}
testevalex {@lset@ x 1 2 1 4}
} {test {1 2 {3 4}}}
test lset-16.5-@mode@ {lset - grow a variable} testevalex {
set x {}
testevalex {@lset@ x end+1 {test 1}}
testevalex {@lset@ x end+1 {test 2}}
set x
} {{test 1} {test 2}}
test lset-16.6-@mode@ {lset - multiple created sublists} testevalex {
set x {}
testevalex {@lset@ x end+1 end+1 {test 1}}
} {{{test 1}}}
test lset-16.7-@mode@ {lset - sublists 3 deep} testevalex {
set x {}
testevalex {@lset@ x end+1 end+1 end+1 {test 1}}
} {{{{test 1}}}}
test lset-16.8-@mode@ {lset - append to inner list} testevalex {
set x {test 1}
testevalex {@lset@ x end end+1 2}
testevalex {@lset@ x end end+1 3}
testevalex {@lset@ x end end end+1 4}
} {test {1 2 {3 4}}}
catch {unset noRead}
catch {unset noWrite}
catch {rename failTrace {}}
catch {unset ::x}
catch {unset ::y}
}]
try $script
}
}
try $tests
if {[info exists ::argv0] && [info script] eq $::argv0} {
try $tests
::tcltest::cleanupTests
return
}
# cleanup
::tcltest::cleanupTests
return
|
|
| > > > > | > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: lset
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
|
| ︙ | ︙ |
1 2 3 4 5 | # This file tests the tclMacOSXFCmd.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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2003 Tcl Core Team.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclMacOSXFCmd.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# These tests really need to be run from a writable directory, which
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: load unload
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set oldTSF $::tcltest::testSingleFile
set ::tcltest::testSingleFile false
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
# This file contains a collection of tests for generic/tclMain.c.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for generic/tclMain.c.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 2006 Donal K. Fellows
# Copyright © 2006 Peter Spjuth
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: ::tcl::mathop::...
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# A namespace to test that operators are exported and that they
|
| ︙ | ︙ |
|
| < < < < < < < > > > > > > > > > > > > > > | 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 |
# Copyright © 1992-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: various
#
# This file contains a collection of miscellaneous Tcl tests that
# don't fit naturally in any of the other test files. Many of these
# tests are pathological cases that caused bugs in earlier Tcl
# releases.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < | > > > > > > > > > > > | 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 © 1998 Mark Harrison.
# Copyright © 1998-1999 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the msgcat package.
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # Functionality covered: this file contains slightly modified versions of # the original tests written by Mike McLennan of Lucent Technologies for # the procedures in tclNamesp.c that implement Tcl's basic support for # namespaces. Other namespace-related tests appear in namespace.test # and variable.test. # # 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1997 Lucent Technologies
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: this file contains slightly modified versions of
# the original tests written by Mike McLennan of Lucent Technologies for
# the procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in namespace.test
# and variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Functionality covered: this file contains a collection of tests for the # procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic # support for namespaces. Other namespace-related tests appear in # variable.test. # # 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 20 21 22 23 24 25 26 27 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic
# support for namespaces. Other namespace-related tests appear in
# variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
|
| ︙ | ︙ |
|
| > > > > | > > > > > > < < < < < | 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 © 2003 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# notify.test --
#
# This file tests several functions in the file, 'generic/tclNotify.c'.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: proc, apply, [interp alias], [namespace import] # # This file contains a collection of tests for the non-recursive executor that # avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the # actual command functionality is tested in the specific test file. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: proc, apply, [interp alias], [namespace import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # 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 20 21 22 23 24 25 26 |
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Copyright © 2021 Nathan Coulter
#
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
testConstraint testindexhex [expr {[namespace which testindexhex] ne {}}]
testConstraint testlistinteger [expr {[namespace which testlistinteger] ne {}}]
apply [list {} {
variable list
variable res
foreach map {
{
@mode@ compiled
@lappend@ lappend
@lindex@ lindex
@linsert@ linsert
@llength@ length
@lrange@ lrange
@lreplace@ lreplace
}
{
@mode@ uncompiled
@lappend@ {[lindex lappend]}
@lindex@ {[lindex lindex]}
@linsert@ {[lindex linsert]}
@llength@ {[lindex llength]}
@lrange@ {[lindex lrange]}
@lreplace@ {[lindex lreplace]}
}
} {
set script [string map $map {
proc data1 iterations {
for {set i 0} {$i < $iterations} {incr i} {
@lappend@ expected [format %x $i]
}
return $expected
}
test {indexhex llength @mode@} {INST_LIST_INDEX_IMM} \
-constraints testindexhex \
-body {
set list [testindexhex]
llength $list
} -cleanup {
catch {unset list}
} -result -1
test {indexhex lindex constant @mode@} {INST_LIST_INDEX_IMM} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lindex@ $list 731
} -cleanup {
catch {unset list}
} -result 2db
test {indexhex lindex constant end @mode@} {INST_LIST_INDEX_IMM} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lindex@ $list end
} -cleanup {
catch {unset list}
catch {unset res}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex lindex dynamic @mode@} {INST_LIST_INDEX} \
-constraints testindexhex \
-body {
set list [testindexhex]
set val [expr {731 + 0}]
@lindex@ $list $val
} -cleanup {
catch {unset list}
} -result 2db
test {indexhex lindex dynamic end @mode@} {INST_LIST_INDEX} \
-constraints testindexhex \
-body {
set index {}
set list [testindexhex]
append index e n d
@lindex@ $list $index
} -cleanup {
catch {unset index}
catch {unset list}
catch {unset res}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex lindex drill @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lindex@ $list 731 0 0 0
} -cleanup {
catch {unset list}
} -result 2db
test {indexhex lrange constant @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lrange@ $list 10 15
} -cleanup {
catch {unset list}
} -result {a b c d e f}
test {indexhex lrange dynamic @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
set first [expr {10 + 0}]
set last [expr {15 + 0}]
@lrange@ $list $first $last
} -cleanup {
catch {unset list}
} -result {a b c d e f}
test {indexhex lrange end constant @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lrange@ $list 10 end
} -cleanup {
catch {unset list}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex lrange end dynamic @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
set back [expr {-5 + 0}]
@lrange@ $list 10 end-$back
} -cleanup {
catch {unset list}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex lrange end minus constant @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
@lrange@ $list 10 end-1
} -cleanup {
catch {unset list}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex lsearch @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
lsearch $list ff
} -cleanup {
catch {unset list}
} -result 255
test {indexhex lsearch sorted @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
lsearch -sorted $list ff
} -cleanup {
catch {unset list}
} -returnCodes 1 -result {sorted list is incoherent}
test {indexhex lsearch start @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
lsearch -start 5171 -glob $list a*
} -cleanup {
catch {unset list}
} -result 40960
test {indexhex string index @mode@} {} \
-constraints testindexhex \
-body {
set iterations 4097
set expected [data1 $iterations]
set list [testindexhex]
set progres {}
set iterations [string length $expected]
for {set i 0} {$i < $iterations} {incr i} {
set eitem [string index $expected $i]
set item [string index $list $i]
if {$item ne $eitem} {
error [list {failed at index} $i [
format %x $i] expected $eitem got $item]
}
@lappend@ progress $item
}
return success
} -cleanup {
catch {unset i}
catch {unset list}
} -result success
test {indexhex string index end @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
string index $list end
return success
} -cleanup {
catch {unset list}
} -returnCodes 1 -result {list length indeterminate}
test {indexhex string length @mode@} {} \
-constraints testindexhex \
-body {
set list [testindexhex]
string length $list
} -cleanup {
catch {unset list}
} -result -1
test {indexhex string range @mode@} {} \
-constraints testindexhex \
-body {
set res {}
set iterations 4097
set data1 [data1 $iterations]
set data1Length [string length $data1]
set list [testindexhex]
for {set first 0} {$first < $data1Length } {
set first [expr {($first + 1) * 2}]} {
for {set last $first} {$last < $data1Length} {
set last [expr {($last + 1) * 3}]} {
set expected [string range $data1 $first $last]
set range [string range $list $first $last]
if {$range ne $expected} {
set length [expr {
max([string length $expected], [string length $range])
}]
for {set i 0} {$i < $length} {incr i} {
set item1 [string index $range $i]
set item2 [string index $expected $i]
if {$item1 ne $item2} {
error [list {failed at} $first $last $i \
expected $item2 got $item1]
}
}
}
}
}
@lappend@ res success
# The largest string index currently allowed.
@lappend@ res [string range $list 2147483640 2147483647]
# This produces an error until index ranges are expanded in some later
# version of Tcl.
set status [catch {string range $list 2147483640 2147483648} cres copts]
@lappend@ res $status $cres
return $res
} -cleanup {
catch {unset list}
} -result {success {d73ac8f } 1 {}}
test {integer lappend @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10
@lappend@ list 11 12 13
} -cleanup {
catch {unset list}
} -result {8 9 10 11 12 13}
test {integer lappend empty @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10
} -cleanup {
catch {unset list}
} -result {8 9 10}
test {integer lappend noninteger @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list {8 9 10 11 12 13}
} -cleanup {
catch {unset list}
} -result {{8 9 10 11 12 13}}
test {integer lindex before before after @mode@} {
This test just tries to trigger a segmentation fault
} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10 11 12 13
@lindex@ $list -1 -1 7
} -cleanup {
catch {unset list}
} -result {}
test {integer lindex middle @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10 11 12 13
@lindex@ $list 3
} -cleanup {
catch {unset list}
} -result 11
test {integer lindex end @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10 11 12 13
@lindex@ $list end
} -cleanup {
catch {unset list}
} -result 13
apply [list {} {
for {set i 0} {$i < 7} {incr i} {
set items {8 9 10 11 12 13}
set results {13 12 11 10 9 8}
set comment [list integer lindex end-$i @mode@]
set body [string map {@i@ $i @items@ $items} {
set list [testlistinteger {}]
@lappend@ list {*}$items
@lindex@ $list end-$i
}]
set result [lindex $results $i]
test $comment {} \
-constraints testlistinteger \
-body $body -cleanup {
catch {unset list}
} -result $result
}
unset i
} [namespace current]]
test {integer linsert middle one @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
set res {}
@lappend@ list 8 9 10 12 13
after 100
lappend res [@linsert@ $list 3 11]
set representation [::tcl::unsupported::representation $list]
regsub {(value is a testListInteger).*} $representation {\1} representation
lappend res $representation
return $res
} -cleanup {
catch {unset list}
catch {unset res}
catch {unset representation}
} -result {{8 9 10 11 12 13} {value is a testListInteger}}
test {integer lrange middle @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10 11 12 13
@lrange@ $list 3 4
} -cleanup {
catch {unset list}
} -result {11 12}
test {integer lreplace prepend @mode@} {} \
-constraints testlistinteger \
-body {
set list [testlistinteger {}]
@lappend@ list 8 9 10 11 12 13
after 100
@lreplace@ $list -1 -1 7
} -cleanup {
catch {unset list}
} -result {7 8 9 10 11 12 13}
}]
#try $script
}
set suites {linsert lset}
foreach suite {linsert lset} {
set namespace [list $suite tests]
namespace eval $namespace [list source [
file join [file dirname [file dirname [
file normalize [file join [info script] ...]]]] $suite.test]]
namespace eval $namespace {
proc newlist list {
if {[string is list $list]} {
set integer 1
foreach item $list {
if {![string is integer $item]} {
set integer 0
break
}
}
if {$integer} {
testlistinteger $list
}
}
return $list
}
try $tests
}
namespace delete $namespace
}
# cleanup
::tcltest::cleanupTests
} [namespace current]]
return
|
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright © 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright © 2006-2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 2019-2020 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for Tcl's built-in object system,
# specifically the parts that support configurable properties on objects.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
package require tcl::oo 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2014-2016 Andreas Kupries
# Copyright © 2018 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for functionality originally
# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
# the tests and generates output for errors. No output means no errors were
# found.
package require tcl::oo 1.3.0
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Package covered: opt1.0/optparse.tcl
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# the package we are going to 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 |
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2011 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the package and ::pkg::* commands.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
namespace eval ::tcl::test::parse {
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the
# file tclCompExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: set (plus basic command syntax). Also tests the # procedures in the file tclOldParse.c. This set of tests is an old # one that predates the new parser in Tcl 8.1. # # 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. | > > > > > > > > > > > > > > < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: set (plus basic command syntax). Also tests the
# procedures in the file tclOldParse.c. This set of tests is an old
# one that predates the new parser in Tcl 8.1.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: pid
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint pidDefined [llength [info commands pid]]
|
| ︙ | ︙ |
1 2 3 4 5 6 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # 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 20 21 22 23 |
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
set fullPkgPath [makeDirectory pkg]
|
| ︙ | ︙ |
1 2 3 4 5 | # The file tests the tcl_platform variable and platform package. # # 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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1999 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The file tests the tcl_platform variable and platform package.
#
# 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.
package require tcltest 2.5
source [file join [file dirname [info script]] tcltests.tcl]
namespace eval ::tcl::test::platform {
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # Commands covered: proc, return, global # # This file, proc-old.test, includes the original set of tests for Tcl's # proc, return, and global commands. There is now a new file proc.test # that contains tests for the tclProc.c source file. # # 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: proc, return, global
#
# This file, proc-old.test, includes the original set of tests for Tcl's
# proc, return, and global commands. There is now a new file proc.test
# that contains tests for the tclProc.c source file.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {rename t1 ""}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # This file contains tests for the tclProc.c source file. Tests appear in the # same order as the C code that they test. The set of tests is currently # incomplete since it includes only new tests, in particular tests for code # changed for the addition of Tcl namespaces. Other procedure-related tests # appear in other test files such as proc-old.test. # # 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 20 21 22 23 24 25 26 27 28 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the tclProc.c source file. Tests appear in the
# same order as the C code that they test. The set of tests is currently
# incomplete since it includes only new tests, in particular tests for code
# changed for the addition of Tcl namespaces. Other procedure-related tests
# appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 | # process.test -- # # This file contains a collection of tests for the tcl::process ensemble. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. | > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 2017 Frederic Bonnet
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# process.test --
#
# This file contains a collection of tests for the tcl::process ensemble.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Utilities
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: pwd
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test pwd-1.1 {simple pwd} {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # reg.test -- # # 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. # (Don't panic if you are seeing this as part of the reg distribution # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) | > > > > > > > > > < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1998, 1999 Henry Spencer. All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# reg.test --
#
# 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.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: regexp, regsub
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain foo
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: regexp, regsub
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # registry.test -- # # This file contains a collection of tests for the registry command. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. | > > > > > > > > > > < < < | 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 © 1997 Sun Microsystems, Inc. All rights reserved.
# Copyright © 1998-1999 Scriptics Corporation.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint reg 0
|
| ︙ | ︙ |
1 2 3 4 5 | # This file contains Tcl code to implement a remote server that can be # used during testing of Tcl socket code. This server is used by some # of the tests in socket.test. # # Source this file in the remote server you are using to test Tcl against. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains Tcl code to implement a remote server that can be
# used during testing of Tcl socket code. This server is used by some
# of the tests in socket.test.
#
# Source this file in the remote server you are using to test Tcl against.
# Initialize message delimiter
# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: rename
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This test collection covers some unwanted interactions between command
# literal sharing and the use of command resolvers (per-interp) which cause
# command literals to be re-used with their command references being invalid
# in the reusing context. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the routines in tclResult.c.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # safe-stock.test -- # # This file contains tests for safe Tcl that were previously in the file # safe.test, and use files and packages of stock Tcl 8.7 to perform the tests. # These files may be changed or disappear in future revisions of Tcl, for # example package opt will eventually be removed. # | > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Copyright © 1995-1996 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # safe-stock.test -- # # This file contains tests for safe Tcl that were previously in the file # safe.test, and use files and packages of stock Tcl 8.7 to perform the tests. # These files may be changed or disappear in future revisions of Tcl, for # example package opt will eventually be removed. # |
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | # tcl::idna to provide alternative tests based on stock Tcl packages. # - These are tests 7.1 7.2 7.4 9.11 9.13 # - Tests 7.[124], 9.1[13] use "package require opt". # - Tests 9.1[13] also use "package require tcl::idna". # - The corresponding tests in safe.test use example packages provided in # subdirectory auto0 of the tests directory, which are independent of any # changes made to the packages provided with Tcl. | < < < < < < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
# tcl::idna to provide alternative tests based on stock Tcl packages.
# - These are tests 7.1 7.2 7.4 9.11 9.13
# - Tests 7.[124], 9.1[13] use "package require opt".
# - Tests 9.1[13] also use "package require tcl::idna".
# - The corresponding tests in safe.test use example packages provided in
# subdirectory auto0 of the tests directory, which are independent of any
# changes made to the packages provided with Tcl.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
foreach i [interp children] {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # safe-zipfs.test -- # # This file contains tests for safe Tcl that test its compatibility with the # zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison # with similar tests in safe.test that do not use the zipfs file system. # # Sourcing this file into tcl runs the tests and generates output for errors. # No output means no errors were found. | > > > > > > > > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# safe-zipfs.test --
#
# This file contains tests for safe Tcl that test its compatibility with the
# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison
# with similar tests in safe.test that do not use the zipfs file system.
#
# Sourcing this file into tcl runs the tests and generates output for errors.
# No output means no errors were found.
apply [list {} {
global auto_path
global tcl_library
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, and # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # # The defunct package http 1.0 was convenient for testing package loading. # - Tests that used http are replaced here with tests that use example packages # provided in subdirectory auto0 of the tests directory, which are independent # of any changes made to the packages provided with Tcl itself. # - These are tests 7.1 7.2 7.4 9.11 9.13 17.1 17.2 17.4 # - Tests 5.* test the example packages themselves before they # are used to test Safe Base interpreters. # - Alternative tests using stock packages of Tcl 8.7 are in file # safe-stock.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 |
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading, and
# using safe interpreters. Sourcing this file into tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# The defunct package http 1.0 was convenient for testing package loading.
# - Tests that used http are replaced here with tests that use example packages
# provided in subdirectory auto0 of the tests directory, which are independent
# of any changes made to the packages provided with Tcl itself.
# - These are tests 7.1 7.2 7.4 9.11 9.13 17.1 17.2 17.4
# - Tests 5.* test the example packages themselves before they
# are used to test Safe Base interpreters.
# - Alternative tests using stock packages of Tcl 8.7 are in file
# safe-stock.test.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: scan
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# procedure that returns the range of integers
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # security.test -- # # Functionality covered: this file contains a collection of tests for the auto # loading and namespaces. # # 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 20 21 22 23 24 25 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# security.test --
#
# Functionality covered: this file contains a collection of tests for the auto
# loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# If this proc becomes invoked, then there is a bug
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: set, unset, array # # This file includes the original set of tests for Tcl's set command. # Since the set command is now compiled, a new set of tests covering # the new implementation is in the file "set.test". 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 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: set, unset, array
#
# This file includes the original set of tests for Tcl's set command.
# Since the set command is now compiled, a new set of tests covering
# the new implementation is in the file "set.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
proc ignore args {}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: set
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 | # Commands tested in this file: socket. # # 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. # | > > > > > > > > > > > > > < < < < < | 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 © 1994-1996 Sun Microsystems, Inc. # Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # Commands tested in this file: socket. # # 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. # # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to # which they connect. The remote server must be an instance of tcltest and it # must run the script found in the file "remote.tcl" in this directory. You |
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 2420 2421 |
close $sock
removeFile script
} -result {{} ok}
test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
-constraints {socket notWinCI} \
-body {
set sock [socket -async localhost [randport]]
fconfigure $sock -blocking 0
puts $sock ok
| > > | | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 |
close $sock
removeFile script
} -result {{} ok}
test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
-constraints {socket notWinCI} \
-body {
set sock [socket -async localhost [randport]]
fileevent $sock writable {incr x}
vwait x
fconfigure $sock -blocking 0
puts $sock ok
fileevent $sock writable {incr x}
vwait x
close $sock
} -cleanup {
catch {close $sock}
unset x
} -result {transport endpoint is not connected} -returnCodes 1
test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: source
#
# 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.
if {[catch {package require tcltest 2.5}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.5 required."
return
}
namespace eval ::tcl::test::source {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: split
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test split-1.1 {basic split commands} {
|
| ︙ | ︙ |
1 2 3 4 5 | # Tests that the stack size is big enough for the application. # # 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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Tests that the stack size is big enough for the application.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Note that a failure in this test may result in a crash of the executable.
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001 Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: string
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: none # # This file contains tests for the procedures in tclStringObj.c that implement # the Tcl type manager for the string type. # # 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 20 21 22 23 24 25 26 27 |
# Copyright © 1995-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: none
#
# This file contains tests for the procedures in tclStringObj.c that implement
# the Tcl type manager for the string type.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: subst
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: switch
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test switch-1.1 {simple patterns} {
|
| ︙ | ︙ |
1 2 3 4 5 | # Commands covered: tailcall # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2008 Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > < | 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 |
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2000 Ajuba Solutions
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself. Ditto on things like [verbose].
#
# It would be better to have the -body of the tests run the tcltest
# commands in a child interp so the [test] being tested would not
# interfere with the [test] doing the testing.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# File permissions broken on wsl without some "exotic" wsl configuration
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 |
#! /usr/bin/env tclsh
# Don't overwrite tcltests facilities already present
if {[package provide tcltests] ne {}} return
package require tcltest 2.5
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
| > > > > > > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#! /usr/bin/env tclsh
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Don't overwrite tcltests facilities already present
if {[package provide tcltests] ne {}} return
package require tcltest 2.5
namespace import ::tcltest::*
testConstraint exec [llength [info commands exec]]
testConstraint debug [tcl::build-info debug]
testConstraint purify [tcl::build-info purify]
testConstraint debugpurify [
expr {
![tcl::build-info memdebug]
&& [testConstraint debug]
&& [testConstraint purify]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2006-2008 Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: (test)thread
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# when thread::release is used, -wait is passed in order allow the thread to
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # This file contains a collection of tests for the procedures in the # file tclTimer.c, which includes the "after" Tcl command. Sourcing # this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # 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. | > > > > > > > > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the
# file tclTimer.c, which includes the "after" Tcl command. Sourcing
# this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
|
| ︙ | ︙ |
1 2 3 4 | # This file contains tests for the ::tcl::tm::* commands. # # 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 20 21 |
# Copyright © 2004 Donal K. Fellows.
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the ::tcl::tm::* commands.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test tm-1.1 {tm: path command exists} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: trace
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 | # This file tests the tclUnixFCmd.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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclUnixFCmd.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 | # This file contains tests for the routines in the file tclUnixFile.c # # 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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the routines in the file tclUnixFile.c
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1995-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for the procedures in the file
# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint testfork [llength [info commands testfork]]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# The file tests the functions in the tclUnixInit.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain path
catch {set oldlang $env(LANG)}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for tclUnixNotfy.c.
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# When run in a Tk shell, these tests hang.
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: unknown
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain x
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2003-2004 Georgios Petasis
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: unload
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: uplevel
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
proc a {x y} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: 'upvar', 'namespace upvar'
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} {
set hi \uD83D
return $hi\uDE02
} \uD83D\uDE02
test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
set lo [testbytestring \x80]
string length [testbytestring \xC0]$lo
| | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
test utf-1.15 {Tcl_UniCharToUtf: surrogate pairs from concat} {
set hi \uD83D
return $hi\uDE02
} \uD83D\uDE02
test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
set lo [testbytestring \x80]
string length [testbytestring \xC0]$lo
} 1
test utf-1.17 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
set hi [testbytestring \xC0]
string length $hi[testbytestring \x80]
} 1
test utf-1.18 {Tcl_UniCharToUtf: surrogate pairs from concat} {
string cat \uD83D \uDE02
} \uD83D\uDE02
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} 3
|
| ︙ | ︙ |
1 2 3 4 5 | # This file contains a collection of tests for Tcl_UtfToExternal and # Tcl_UtfToExternal that exercise various combinations of flags, # buffer lengths and fragmentation that cannot be tested by # normal script level commands. There tests are NOT intended to check # correct encodings; those are elsewhere. | > > > > > > > > > > > > > < < < < < | 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) 2023 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Copyright (c) 2024 Nathan Coulter
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains a collection of tests for Tcl_UtfToExternal and
# Tcl_UtfToExternal that exercise various combinations of flags,
# buffer lengths and fragmentation that cannot be tested by
# normal script level commands. There tests are NOT intended to check
# correct encodings; those are elsewhere.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright © 1995-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 | # This file contains tests for the tclVar.c source file. Tests appear in the # same order as the C code that they test. The set of tests is currently # incomplete since it currently includes only new tests for code changed for # the addition of Tcl namespaces. Other variable-related tests appear in # several other test files including namespace.test, set.test, trace.test, and # upvar.test. # # 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 20 21 22 23 24 25 26 27 28 29 |
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file contains tests for the tclVar.c source file. Tests appear in the
# same order as the C code that they test. The set of tests is currently
# incomplete since it currently includes only new tests for code changed for
# the addition of Tcl namespaces. Other variable-related tests appear in
# several other test files including namespace.test, set.test, trace.test, and
# upvar.test.
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # Commands covered: while # # This file contains the original set of tests for Tcl's while command. # Since the while command is now compiled, a new set of tests covering # the new implementation is in the file "while.test". 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 20 21 22 23 24 25 26 27 28 |
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: while
#
# This file contains the original set of tests for Tcl's while command.
# Since the while command is now compiled, a new set of tests covering
# the new implementation is in the file "while.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
test while-old-1.1 {basic while loops} {
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Commands covered: while
#
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
# Basic "while" operation.
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # This file tests the tclWinConsole.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. # # NOTE THIS CANNOT BE RUN VIA nmake/make test since stdin is connected to # nmake in that case. | > > > > > > > > > > < < < | 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 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinConsole.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.
#
# NOTE THIS CANNOT BE RUN VIA nmake/make test since stdin is connected to
# nmake in that case.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
catch {package require twapi} ;# Only to bring window to foreground. Not critical
|
| ︙ | ︙ |
1 2 3 4 5 | # This file tests the tclWinDde.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. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinDde.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinFCmd.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinFile.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinNotify.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # # winPipe.test -- # # This file contains a collection of tests for tclWinPipe.c # # Sourcing this file into Tcl runs the tests and generates output for errors. # No output (except for one message) means no errors were found. | > > > > > > > > > > > > < < < < < < | 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 © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# winPipe.test --
#
# This file contains a collection of tests for tclWinPipe.c
#
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output (except for one message) means no errors were found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
unset -nocomplain path
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# This file tests the tclWinTime.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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
|
| ︙ | ︙ |
|
| < < < < < < | > > > > > > > > > > > > | 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 © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2023 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# Copyright © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
source [file join [file dirname [info script]] tcltests.tcl]
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | # checkLibraryDoc.tcl -- # # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list # against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. # 3) Internal APIs and structs. # 4) Misc APIs and structs that we are not documenting. # 5) Command APIs (e.g., Tcl_ArrayObjCmd.) # 6) Proc pointers (e.g., Tcl_CloseProc.) # # Note: Each list is "a best guess" approximation. If developers write # non-standard code, this script will produce erroneous results. Each # list should be carefully checked for accuracy. | > > > > > > > > > > | < < | 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 |
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# checkLibraryDoc.tcl --
#
# This script attempts to determine what APIs exist in the source base that
# have not been documented. By grepping through all of the doc/*.3 man
# pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list
# against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch])
# we create six lists:
# 1) APIs in Source not in Docs.
# 2) APIs in Docs not in Source.
# 3) Internal APIs and structs.
# 4) Misc APIs and structs that we are not documenting.
# 5) Command APIs (e.g., Tcl_ArrayObjCmd.)
# 6) Proc pointers (e.g., Tcl_CloseProc.)
#
# Note: Each list is "a best guess" approximation. If developers write
# non-standard code, this script will produce erroneous results. Each
# list should be carefully checked for accuracy.
lappend auto_path "c:/program\ files/tclpro1.2/win32-ix86/bin"
#lappend auto_path "/home/surles/cvs/tclx8.0/tcl/unix"
if {[catch {package require Tclx}]} {
puts "error: could not load TclX. Please set TCL_LIBRARY."
exit 1
|
| ︙ | ︙ |
|
| < < < < < < < < < < | 1 2 3 4 5 6 7 | #--------------------------------------------------------------------------- # # Copyright (c) 1996 Unicode, Inc. All Rights reserved. # # This file is provided as-is by Unicode, Inc. (The Unicode Consortium). # No claims are made as to fitness for any particular purpose. No # warranties of any kind are expressed or implied. The recipient |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # # In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # | | > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < | 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 | # specifically excludes the right to re-distribute this file directly # to third parties or other organizations whether for profit or not. # # In other words: Don't put this file on the Internet. People who want to # get it over the Internet should do so directly from ftp://unicode.org. They # can therefore be assured of getting the most recent and accurate version. # # Copyright (c) 1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # SCCS: @(#) Makefile 1.1 98/01/28 11:41:36 # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file is a Makefile to compile all the encoding files. # # Run "make" to compile all the encoding files (*.txt,*.esc) into the # format that Tcl can use (*.enc). It is your responsibility to move the # encoding files to the appropriate place ($TCL_ROOT/library/encoding # # The .txt files in this directory come from the Unicode CD and are covered # by the following copyright notice: # The txt2enc program built by this makefile is used to compile individual # .txt files into .enc files, the format that Tcl understands for encoding # files. This compilation to a different format is allowed by the above # restriction. # # The files shiftjis.txt and jis0208.txt were modified from the original # ones provided on the Unicode CD. The double-width backslash character # 0x815F in these two Japanese encodings was being mapped to Unicode 005C # (REVERSE SOLIDUS), the normal backslash character. They have been # changed to map 0x815F to Unicode FF3C (FULLWIDTH REVERSE SOLIDUS) and let # the regular backslash character map to itself. This follows how cp932 # behaves. EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt encodings: clean txt2enc $(EUC_ENCODINGS) @echo Compiling encoding files. @for p in *.esc; do \ base=`echo $$p | sed 's/\..*$$//'`; \ |
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * 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. * * SCCS: @(#) txt2enc.c 1.1 98/01/28 11:42:09 */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * txt2enc.c -- * * Simple program to compile up the encodings tables from the CD that * came with "The Unicode Standard, Version 2.0" into a form that can * be quickly loaded into Tcl. */ #include <stdio.h> #include <stdlib.h> #include <ctype.h> #include <string.h> #include <unistd.h> typedef unsigned short Rune; |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | # findBadExternals.tcl -- # # This script scans the Tcl load library for exported symbols # that do not begin with 'Tcl' or 'tcl'. It reports them on the # standard output. It is used to make sure that the library does # not inadvertently export externals that may be in conflict with # other code. # # Usage: # # tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll | > > > > > > > > > > > > < < < < < < | 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 |
# Copyright © 2005 George Peter Staplin and Kevin Kenny
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# findBadExternals.tcl --
#
# This script scans the Tcl load library for exported symbols
# that do not begin with 'Tcl' or 'tcl'. It reports them on the
# standard output. It is used to make sure that the library does
# not inadvertently export externals that may be in conflict with
# other code.
#
# Usage:
#
# tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll
proc main {argc argv} {
if {$argc != 1} {
puts stderr "syntax is: [info script] libtcl"
return 1
}
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# genStubs.tcl --
#
# This script generates a set of stub files for a given
# interface.
namespace eval genStubs {
# libraryName --
#
# The name of the entire library. This value is used to compute
# the USE_*_STUBS macro and the name of the init file.
|
| ︙ | ︙ |
1 2 3 4 5 | # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. | > > > > > > > > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | # Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value # of topic ID. |
| ︙ | ︙ |
|
| | | > > > > | > > > > > > < < < < < | 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 |
#! /usr/bin/env tclsh
# Copyright © 2004 Kevin B. Kenny. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
#
# installData.tcl --
#
# This file installs a hierarchy of data found in the directory
# specified by its first argument into the directory specified
# by its second.
#
#----------------------------------------------------------------------
proc copyDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
[file tail $d2]]
|
| ︙ | ︙ |
|
| | | > > > | > > > > > > < < < < < | 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 |
#! /usr/bin/env tclsh
# Copyright © 2018 Sean Woods. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
#
# installVfs.tcl --
#
# This file wraps the /library file system around a binary
#
#----------------------------------------------------------------------
proc mapDir {resultvar prefix filepath} {
upvar 1 $resultvar result
if {![info exists result]} {
set result {}
}
|
| ︙ | ︙ |
|
| > > > > > > > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | #! /usr/bin/env tclsh # Copyright © 2004 Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #--------------------------------------------------------------------- # # loadICU,tcl -- # # Extracts locale strings from a distribution of ICU # (http://oss.software.ibm.com/developerworks/opensource/icu/project/) # and makes Tcl message catalogs for the 'clock' command. # |
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | # # Results: # None. # # Side effects: # Creates the message catalogs. # | < < < < < | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | # # Results: # None. # # Side effects: # Creates the message catalogs. # #---------------------------------------------------------------------- puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences" exit; # Remove those two lines after modifying this tool. # Calculate the Chinese numerals from zero to ninety-nine. |
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
# Write the Tcl message catalog
set f [open $msgFileName w]
# Write a header
puts $f "\# created by $::argv0 -- do not edit"
| < | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
# Write the Tcl message catalog
set f [open $msgFileName w]
# Write a header
puts $f "\# created by $::argv0 -- do not edit"
# Do ordinary sets of strings (weekday and month names)
foreach key {
DayAbbreviations DayNames MonthAbbreviations MonthNames
} tkey {
DAYS_OF_WEEK_ABBREV DAYS_OF_WEEK_FULL
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
[backslashify $format($localeName,$key)] "\""
puts $f $cmd
}
}
# Footer
| < | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
[backslashify $format($localeName,$key)] "\""
puts $f $cmd
}
}
# Footer
close $f
}
#----------------------------------------------------------------------
#
# percentify --
#
|
| ︙ | ︙ |
1 2 3 4 5 | # makeHeader.tcl -- # # This script generates embeddable C source (in a .h file) from a .tcl # script. # | > > > > > > > > > > > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright © 2018 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# makeHeader.tcl --
#
# This script generates embeddable C source (in a .h file) from a .tcl
# script.
#
package require Tcl 8.6-
namespace eval makeHeader {
####################################################################
#
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # TODO - When integrating this with the Core, path names will need to be # swizzled here. package require msgcat set d [file dirname [file dirname [info script]]] puts "getting transition data from [file join $d library tzdata America Detroit]" source -encoding utf-8 [file join $d library/tzdata/America/Detroit] | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | #! /usr/bin/env tclsh # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # TODO - When integrating this with the Core, path names will need to be # swizzled here. package require msgcat set d [file dirname [file dirname [info script]]] puts "getting transition data from [file join $d library tzdata America Detroit]" source -encoding utf-8 [file join $d library/tzdata/America/Detroit] |
| ︙ | ︙ |
1 2 3 4 5 6 7 |
proc cat fname {
set fname [open $fname r]
set data [read $fname]
close $fname
return $data
}
| > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
proc cat fname {
set fname [open $fname r]
set data [read $fname]
close $fname
return $data
}
|
| ︙ | ︙ |
1 | #============================================================================== | < < < > > > > > > > > > > | 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 |
#==============================================================================
# Copyright © 1998, Nat Pryce
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
#
# IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT,
# SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF
# THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED
# OF THE POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
# BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT,
# UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#==============================================================================
#
# Modified heavily by David Gravereaux <davygrvy@pobox.com> about 9/17/2006.
# Original can be found @
# http://web.archive.org/web/20070616205924/http://www.doc.ic.ac.uk/~np2/software/mkdepend.html
#==============================================================================
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# mkdepend : generate dependency information from C/C++ files
array set mode_data {}
set mode_data(vc32) {cl -nologo -E}
set source_extensions [list .c .cpp .cxx .cc]
set excludes [list]
|
| ︙ | ︙ |
1 2 3 4 5 | # regexpTestLib.tcl -- # # This file contains tcl procedures used by spencer2testregexp.tcl and # spencer2regexp.tcl, which are programs written to convert Henry # Spencer's test suite to tcl test files. | > > > > > > > > > < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Copyright © 1996 Sun Microsystems, Inc.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# regexpTestLib.tcl --
#
# This file contains tcl procedures used by spencer2testregexp.tcl and
# spencer2regexp.tcl, which are programs written to convert Henry
# Spencer's test suite to tcl test files.
proc readInputFile {} {
global inFileName
global lineArray
set fileId [open $inFileName r]
|
| ︙ | ︙ |
|
| < < < < < < > > > > > > > > > > > > > | 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 © 2012-2019 Donal K. Fellows
# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# tclOOScript.h --
#
# This file contains support scripts for TclOO. They are defined here so
# that the code can be definitely run even in safe interpreters; TclOO's
# core setup is safe.
::namespace eval ::oo {
::namespace path {}
#
# Commands that are made available to objects by default.
#
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | #---------------------------------------------------------------------- # # tclZIC.tcl -- # # Take the time zone data source files from Arthur Olson's # repository at https://www.iana.org/time-zones, and prepare time zone # information files for Tcl. | > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # Copyright © 2004 Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- # # tclZIC.tcl -- # # Take the time zone data source files from Arthur Olson's # repository at https://www.iana.org/time-zones, and prepare time zone # information files for Tcl. |
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | # May produce error messages on the standard error. An exit # code of zero denotes success; any other exit code is failure. # # This program parses the timezone data in a means analogous to the # 'zic' command, and produces Tcl time zone information files suitable # for loading into the 'clock' namespace. # | < < < < < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
# May produce error messages on the standard error. An exit
# code of zero denotes success; any other exit code is failure.
#
# This program parses the timezone data in a means analogous to the
# 'zic' command, and produces Tcl time zone information files suitable
# for loading into the 'clock' namespace.
#
#----------------------------------------------------------------------
# Define the names of the Olson files that we need to load.
# We avoid the solar time files and the leap seconds.
set olsonFiles {
africa antarctica asia australasia
|
| ︙ | ︙ |
|
| > > | > > > > > > > | | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Copyright © 1995-1997 Roger E. Critchlow Jr
# Copyright © 2004-2011 Donal K. Fellows
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Utility functions for Man->HTML converter. Note that these
# functions are specifically intended to work with the format as used
# by Tcl and Tk; they do not cope with arbitrary nroff markup.
set ::manual(report-level) 1
proc manerror {msg} {
global manual
set name {}
set subj {}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
#!/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.
| > > > > > > > > > > < < < | 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 |
#!/usr/bin/env tclsh
# Copyright © 1995-1997 Roger E. Critchlow Jr
# Copyright © 2004-2010 Donal K. Fellows
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
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.
set ::Version "50/9.0"
set ::CSSFILE "docs.css"
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
#include <tcl.h>
extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
| > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <tcl.h>
extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
typedef struct {
|
| ︙ | ︙ |
1 2 3 4 5 6 7 |
package require Thread
set ::tids [list]
for {set i 0} {$i < 4} {incr i} {
lappend ::tids [thread::create [string map [list IVALUE $i] {
set curdir [file dirname [info script]]
| > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
#! /usr/bin/env tclsh
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Thread
set ::tids [list]
for {set i 0} {$i < 4} {incr i} {
lappend ::tids [thread::create [string map [list IVALUE $i] {
set curdir [file dirname [info script]]
|
| ︙ | ︙ |
|
| | | | > > | > > | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
#! /usr/bin/env tclsh
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# uniClass.tcl --
#
# Generates the character ranges and singletons that are used in
# generic/regc_locale.c for translation of character classes.
# This file must be generated using a tclsh that contains the
# correct corresponding tclUniData.c file (generated by uniParse.tcl)
# in order for the class ranges to match.
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xFFFF} {
set extranges 1
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | # uniParse.tcl -- # # This program parses the UnicodeData file and generates the # corresponding tclUniData.c file with compressed character # data tables. The input to this program should be the latest # UnicodeData file from: # ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.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 |
#! /usr/bin/env tclsh
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# uniParse.tcl --
#
# This program parses the UnicodeData file and generates the
# corresponding tclUniData.c file with compressed character
# data tables. The input to this program should be the latest
# UnicodeData file from:
# ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt
namespace eval uni {
set shift 5; # number of bits of data within a page
# This value can be adjusted to find the
# best split to minimize table size
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
set last [expr {[llength $pMap] - 1}]
for {set i 0} {$i <= $last} {incr i} {
if {$i == [expr {0x10000 >> $shift}]} {
set line [string trimright $line " \t,"]
puts $f $line
set lastpage [expr {[lindex $line end] >> $shift}]
puts stdout "lastpage: $lastpage"
| < < < < | 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 |
set last [expr {[llength $pMap] - 1}]
for {set i 0} {$i <= $last} {incr i} {
if {$i == [expr {0x10000 >> $shift}]} {
set line [string trimright $line " \t,"]
puts $f $line
set lastpage [expr {[lindex $line end] >> $shift}]
puts stdout "lastpage: $lastpage"
set line " ,"
}
append line [lindex $pMap $i]
if {$i != $last} {
append line ", "
}
if {[string length $line] > 70} {
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts $f "};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
*/
static const unsigned char groupMap\[\] = {"
set line " "
set lasti [expr {[llength $pages] - 1}]
for {set i 0} {$i <= $lasti} {incr i} {
set page [lindex $pages $i]
set lastj [expr {[llength $page] - 1}]
if {$i == ($lastpage + 1)} {
puts $f [string trimright $line " \t,"]
set line " ,"
}
for {set j 0} {$j <= $lastj} {incr j} {
append line [lindex $page $j]
if {$j != $lastj || $i != $lasti} {
append line ", "
}
if {[string length $line] > 70} {
puts $f [string trimright $line]
set line " "
}
}
}
puts $f $line
puts $f "};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
*
* Bits 0-4 Character category: see the constants listed below.
|
| ︙ | ︙ | |||
338 339 340 341 342 343 344 |
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts -nonewline $f "};
| < | < < < | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= [format 0x%X $next])
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
enum {
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 | #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ | < | < < < | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
"
close $f
}
uni::main
return
|
1 2 3 4 5 6 7 8 9 |
#! /usr/bin/env tclsh
proc main {sourcetype source} {
switch $sourcetype {
file {
set chan [open $source]
try {
set data [read $chan]
| > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
#! /usr/bin/env tclsh
# Copyright © 2021 Nathan Coulter
# You may distribute and/or modify this program under the terms of the GNU
# Affero General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# See the file "COPYING" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
proc main {sourcetype source} {
switch $sourcetype {
file {
set chan [open $source]
try {
set data [read $chan]
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
| < < < < < | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
# Some versions of make, like SGI's, use the following variable to determine
# which shell to use for executing commands:
SHELL = @MAKEFILE_SHELL@
# Tcl used to let the configure script choose which program to use for
# installing, but there are just too many different versions of "install"
# around; better to use the install-sh script that comes with the
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
| | > | > | | > | | | | | | | 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 |
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o tclTestObjInterface.o \
tclTestObjInterfaceInteger.o tclTestABSList.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestObjInterface.o \
tclTestObjInterfaceInteger.o tclTestABSList.o\
tclTestProcBodyObj.o tclThreadTest.o tclUnixTest.o tclXtNotify.o \
tclXtTest.o
GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \
tclCkalloc.o tclClock.o tclClockClassic.o tclClockFmt.o tclCmdAH.o \
tclCmdIL.o tclCmdMZ.o \
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
tclCompile.o tclConfig.o tclDate.o tclDateClassic.o tclDictObj.o \
tclDisassemble.o tclEncoding.o tclEnsemble.o \
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
tclHash.o tclHistory.o \
tclIcu.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
tclLink.o tclListObj.o \
tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
tclObj.o tclObjInterface.o tclOptimize.o tclPanic.o tclParse.o \
tclPathObj.o tclPipe.o tclPkg.o tclPkgConfig.o tclPosixStr.o \
tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStrIdxTree.o tclStringObj.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
tclTomMathInterface.o tclZipfs.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
tclOOMethod.o tclOOProp.o tclOOStubInit.o
|
| ︙ | ︙ | |||
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 | $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ $(GENERIC_DIR)/tclClock.c \ $(GENERIC_DIR)/tclClockFmt.c \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ $(GENERIC_DIR)/tclCompCmds.c \ $(GENERIC_DIR)/tclCompCmdsGR.c \ $(GENERIC_DIR)/tclCompCmdsSZ.c \ $(GENERIC_DIR)/tclCompExpr.c \ $(GENERIC_DIR)/tclCompile.c \ $(GENERIC_DIR)/tclConfig.c \ $(GENERIC_DIR)/tclDate.c \ $(GENERIC_DIR)/tclDictObj.c \ $(GENERIC_DIR)/tclDisassemble.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ | > > | 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 | $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ $(GENERIC_DIR)/tclClock.c \ $(GENERIC_DIR)/tclClockClassic.c \ $(GENERIC_DIR)/tclClockFmt.c \ $(GENERIC_DIR)/tclCmdAH.c \ $(GENERIC_DIR)/tclCmdIL.c \ $(GENERIC_DIR)/tclCmdMZ.c \ $(GENERIC_DIR)/tclCompCmds.c \ $(GENERIC_DIR)/tclCompCmdsGR.c \ $(GENERIC_DIR)/tclCompCmdsSZ.c \ $(GENERIC_DIR)/tclCompExpr.c \ $(GENERIC_DIR)/tclCompile.c \ $(GENERIC_DIR)/tclConfig.c \ $(GENERIC_DIR)/tclDate.c \ $(GENERIC_DIR)/tclDateClassic.c \ $(GENERIC_DIR)/tclDictObj.c \ $(GENERIC_DIR)/tclDisassemble.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ |
| ︙ | ︙ | |||
449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 | $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ $(GENERIC_DIR)/tclOptimize.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ | > | | > > | 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 | $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ $(GENERIC_DIR)/tclObjInterface.c \ $(GENERIC_DIR)/tclOptimize.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStrIdxTree.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestObjInterface.c \ $(GENERIC_DIR)/tclTestObjInterfaceInteger \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ $(GENERIC_DIR)/tclTrace.c \ |
| ︙ | ︙ | |||
956 957 958 959 960 961 962 963 964 965 966 967 968 969 |
shell: ${TCL_EXE}
$(SHELL_ENV) ./${TCL_EXE} $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: ${TCL_EXE}
$(SHELL_ENV) $(GDB) ./${TCL_EXE}
lldb: ${TCL_EXE}
$(SHELL_ENV) $(LLDB) ./${TCL_EXE}
valgrind: ${TCL_EXE} ${TCLTEST_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \
$(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
$(TESTFLAGS)
| > > > | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
shell: ${TCL_EXE}
$(SHELL_ENV) ./${TCL_EXE} $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: ${TCL_EXE}
$(SHELL_ENV) $(GDB) ./${TCL_EXE}
gdb-script: ${TCLTEST_EXE}
$(SHELL_ENV) $(GDB) --args $(SCRIPT)
lldb: ${TCL_EXE}
$(SHELL_ENV) $(LLDB) ./${TCL_EXE}
valgrind: ${TCL_EXE} ${TCLTEST_EXE}
$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} \
$(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind \
$(TESTFLAGS)
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
TCLDATEHDR=$(GENERIC_DIR)/tclDate.h $(GENERIC_DIR)/tclStrIdxTree.h
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
$(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c
| > | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
TCLDATEHDR=$(GENERIC_DIR)/tclDate.h $(GENERIC_DIR)/tclStrIdxTree.h
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
$(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regcomp.c
|
| ︙ | ︙ | |||
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 | tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c tclClock.o: $(GENERIC_DIR)/tclClock.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c tclClockFmt.o: $(GENERIC_DIR)/tclClockFmt.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClockFmt.c tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) | > > > > > > | 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 | tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c tclClock.o: $(GENERIC_DIR)/tclClock.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c tclClockClassic.o: $(GENERIC_DIR)/tclClockClassic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClockClassic.c tclClockFmt.o: $(GENERIC_DIR)/tclClockFmt.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClockFmt.c tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c tclDateClassic.o: $(GENERIC_DIR)/tclDateClassic.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDateClassic.c tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) |
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclOptimize.o: $(GENERIC_DIR)/tclOptimize.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOptimize.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c | > > > | 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclObjInterface.o: $(GENERIC_DIR)/tclObjInterface.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObjInterface.c tclOptimize.o: $(GENERIC_DIR)/tclOptimize.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOptimize.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c |
| ︙ | ︙ | |||
1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c tclResult.o: $(GENERIC_DIR)/tclResult.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c | > > > < < < | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 | $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c tclResult.o: $(GENERIC_DIR)/tclResult.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResult.c tclScan.o: $(GENERIC_DIR)/tclScan.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c tclStrIdxTree.o: $(GENERIC_DIR)/tclStrIdxTree.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrIdxTree.c tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c |
| ︙ | ︙ | |||
1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 | tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c tclTimer.o: $(GENERIC_DIR)/tclTimer.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c tclThread.o: $(GENERIC_DIR)/tclThread.c | > > > > > > > | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 | tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c tclTestObjInterface.o: $(GENERIC_DIR)/tclTestObjInterface.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObjInterface.c tclTestObjInterfaceInteger.o: $(GENERIC_DIR)/tclTestObjInterfaceInteger.c \ $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObjInterfaceInteger.c tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c tclTimer.o: $(GENERIC_DIR)/tclTimer.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c tclThread.o: $(GENERIC_DIR)/tclThread.c |
| ︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 | # -e '/TclDatenewstate:/d' -e '/#pragma/d' \ # -e '/#include <inttypes.h>/d' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDate.c # rm y.tab.c # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls $(GENERIC_DIR)/tclTomMath.decls @echo "Warning: tclStubInit.c may be out of date." | > > > > > > > > > > > > > > > > > > | 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 | # -e '/TclDatenewstate:/d' -e '/#pragma/d' \ # -e '/#include <inttypes.h>/d' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDate.c # rm y.tab.c # Remark: see [54a305cb88]. tclDateClassic.c is manually edited, removing the unused "yynerrs" variable gendateclassic: bison --output-file=$(GENERIC_DIR)/tclDateClassic.c \ --no-lines \ --name-prefix=TclDateClassic \ $(GENERIC_DIR)/tclGetDateClassic.y # yacc -l $(GENERIC_DIR)/tclGetDateClassic.y # sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ # -e 's?SCCSID?RCS: @(#) ?' \ # -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ # -e '/TclDatenewstate:/d' -e '/#pragma/d' \ # -e '/#include <inttypes.h>/d' \ # -e '/#define YYNEW/s/malloc/TclDateClassicAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateClassicRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDateClassic.c # rm y.tab.c # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls $(GENERIC_DIR)/tclTomMath.decls @echo "Warning: tclStubInit.c may be out of date." |
| ︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix $(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix $(INSTALL_DATA_DIR) $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(TOP_DIR)/changes.md $(TOP_DIR)/README.md \ $(TOP_DIR)/license.terms $(DISTDIR) $(INSTALL_DATA_DIR) $(DISTDIR)/library $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/manifest.txt \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library @for i in $(BUILTIN_PACKAGE_LIST); do \ | > | 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 | $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix $(DIST_INSTALL_SCRIPT) $(UNIX_DIR)/configure $(UNIX_DIR)/ldAix $(DISTDIR)/unix $(INSTALL_DATA_DIR) $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/*.decls $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/README $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(GENERIC_DIR)/tclGetDateClassic.y $(DISTDIR)/generic $(DIST_INSTALL_DATA) $(TOP_DIR)/changes.md $(TOP_DIR)/README.md \ $(TOP_DIR)/license.terms $(DISTDIR) $(INSTALL_DATA_DIR) $(DISTDIR)/library $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/manifest.txt \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library @for i in $(BUILTIN_PACKAGE_LIST); do \ |
| ︙ | ︙ |
more than 10,000 changes
1 2 3 4 5 6 7 8 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.0]) AC_PREREQ([2.69]) | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | #! /bin/bash -norc # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.0]) AC_PREREQ([2.69]) |
| ︙ | ︙ |
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | DLTEST_SUFFIX = @DLTEST_SUFFIX@ SRC_DIR = @TCL_SRC_DIR@/unix/dltest BUILD_DIR = @builddir@ TCL_VERSION= @TCL_VERSION@ CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ | | | | < < < < < < < < < < < < | 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 |
DLTEST_SUFFIX = @DLTEST_SUFFIX@
SRC_DIR = @TCL_SRC_DIR@/unix/dltest
BUILD_DIR = @builddir@
TCL_VERSION= @TCL_VERSION@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -Wall -Wextra -Wc++-compat -Wconversion -Werror
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} \
tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgt${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} \
tcl9pkgooa${SHLIB_SUFFIX}
@if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi
@touch ../dltest.marker
dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} \
tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgt${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} \
tcl9pkgooa${DLTEST_SUFFIX}
@touch ../dltest.marker
embtest.o: $(SRC_DIR)/embtest.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/embtest.c
pkgπ.o: $(SRC_DIR)/pkgπ.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgπ.c
pkga.o: $(SRC_DIR)/pkga.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
pkgb.o: $(SRC_DIR)/pkgb.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c
pkgc.o: $(SRC_DIR)/pkgc.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c
pkgt.o: $(SRC_DIR)/pkgt.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgt.c
pkgd.o: $(SRC_DIR)/pkgd.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c
pkge.o: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
pkgua.o: $(SRC_DIR)/pkgua.c
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
tcl9pkgc${SHLIB_SUFFIX}: pkgc.o
${SHLIB_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS}
tcl9pkgt${SHLIB_SUFFIX}: pkgt.o
${SHLIB_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS}
| < < < < < < < < < < < < | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
tcl9pkgc${SHLIB_SUFFIX}: pkgc.o
${SHLIB_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS}
tcl9pkgt${SHLIB_SUFFIX}: pkgt.o
${SHLIB_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS}
tcl9pkgd${SHLIB_SUFFIX}: pkgd.o
${SHLIB_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS}
tcl9pkge${SHLIB_SUFFIX}: pkge.o
${SHLIB_LD} -o $@ pkge.o ${SHLIB_LD_LIBS}
tcl9pkgua${SHLIB_SUFFIX}: pkgua.o
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
tcl9pkgc${DLTEST_SUFFIX}: pkgc.o
${DLTEST_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS}
tcl9pkgt${DLTEST_SUFFIX}: pkgt.o
${DLTEST_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS}
| < < < < < < < < < < < < | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
tcl9pkgc${DLTEST_SUFFIX}: pkgc.o
${DLTEST_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS}
tcl9pkgt${DLTEST_SUFFIX}: pkgt.o
${DLTEST_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS}
tcl9pkgd${DLTEST_SUFFIX}: pkgd.o
${DLTEST_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS}
tcl9pkge${DLTEST_SUFFIX}: pkge.o
${DLTEST_LD} -o $@ pkge.o ${SHLIB_LD_LIBS}
tcl9pkgua${DLTEST_SUFFIX}: pkgua.o
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | #!/bin/sh ######################################################################## ### Parse Options ### Gzip=: Sym="" | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | #!/bin/sh # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. ######################################################################## ### Parse Options ### Gzip=: Sym="" |
| ︙ | ︙ |
1 | #!/bin/sh | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | #!/bin/sh # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ldAix ldCmd ldArg ldArg ... # # This shell script provides a wrapper for ld under AIX in order to # create the .exp file required for linking. Its arguments consist # of the name and arguments that would normally be provided to the # ld command. This script extracts the names of the object files # from the argument list, creates a .exp file describing all of the |
| ︙ | ︙ |
1 2 3 4 5 6 7 | #------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: |
| ︙ | ︙ |
1 2 3 4 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
| | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tclunchained
Summary: TclUnchained scripting language development environment
Version: 9.0b4
Release: 2
License: GNU Affero General Public License
Group: Development/Languages
Source: http://prdownloads.sourceforge.net/tcl/tclunchained%{version}-src.tar.gz
URL: https://www.tcl-lang.org/
Buildroot: /var/tmp/%{name}%{version}
%description
Tcl (Tool Command Language) Unchained provides a powerful platform for
creating integration applications that tie together diverse
applications, protocols, devices, and frameworks. When paired with
the Tk toolkit, Tcl provides the fastest and most powerful way to
create GUI applications that run on PCs, Unix, and Mac OS X. Tcl
can also be used for a variety of web-related tasks and for creating
powerful command languages for applications.
|
| ︙ | ︙ |
1 | /* | < < < < < < > | | | | > > > | > | > > > > | < < > | | 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 | /* * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for tclsh and other Tcl-based applications (without Tk). */ #include "tcl.h" #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #ifdef TCL_XT_TEST extern void XtToolkitInitialize(void); extern Tcl_LibraryInitProc Tclxttest_Init; #endif /* TCL_XT_TEST */ /* * The following #if block allows you to change the AppInit function by using * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The * #if checks for that #define and uses Tcl_AppInit if it does not exist. |
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
{
#ifdef TCL_XT_TEST
XtToolkitInitialize();
#endif
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
{
#ifdef TCL_XT_TEST
XtToolkitInitialize();
#endif
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif !defined(_WIN32) || defined(UNICODE)
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclEpollNotfy.c -- * * This file contains the implementation of the epoll()-based * Linux-specific notifier, which is the lowest-level part of the Tcl * event loop. This file works together with generic/tclNotify.c. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_EPOLL) && TCL_THREADS #ifndef _GNU_SOURCE # define _GNU_SOURCE /* For pipe2(2) */ #endif |
| ︙ | ︙ | |||
38 39 40 41 42 43 44 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
LIST_ENTRY(FileHandler) readyNode;
/* Next/previous in list of FileHandlers asso-
* ciated with regular files (S_IFREG) that are
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
*/
if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
}
if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) {
| | | | | | | | | | | | | | < | | | | 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 |
*/
if (TclOSfstat(filePtr->fd, &fdStat) == -1) {
Tcl_Panic("fstat: %s", strerror(errno));
}
if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) {
switch (errno) {
case EPERM:
switch (op) {
case EPOLL_CTL_ADD:
if (isNew) {
LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr,
filePtr, readyNode);
}
break;
case EPOLL_CTL_DEL:
LIST_REMOVE(filePtr, readyNode);
break;
}
break;
default:
Tcl_Panic("epoll_ctl: %s", strerror(errno));
}
}
return;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
int isNew = (filePtr == NULL);
if (isNew) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
| | | 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
void *clientData, /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclKqueueNotfy.c -- * * This file contains the implementation of the kqueue()-based * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest- * level part of the Tcl event loop. This file works together with * generic/tclNotify.c. | > > > > > > > > > > > > > > > > > < < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclKqueueNotfy.c -- * * This file contains the implementation of the kqueue()-based * DragonFly/Free/Net/OpenBSD-specific notifier, which is the lowest- * level part of the Tcl event loop. This file works together with * generic/tclNotify.c. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_KQUEUE) && TCL_THREADS |
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
LIST_ENTRY(FileHandler) readyNode;
/* Next/previous in list of FileHandlers asso-
* ciated with regular files (S_IFREG) that are
* ready for I/O. */
struct PlatformEventData *pedPtr;
/* Pointer to PlatformEventData associating this
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
int isNew = (filePtr == NULL);
if (isNew) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
| | | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
Tcl_ThreadId threadId, /* Target thread. */
void *clientData, /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclLoadAix.c -- * * This file implements the dlopen and dlsym APIs under the AIX operating * system, to enable the Tcl "load" command to work. This code was * provided by Jens-Uwe Mager. * | > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | /* * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 * This is an unpublished work copyright © 1992 HELIOS Software GmbH * 30159 Hannover, Germany */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadAix.c -- * * This file implements the dlopen and dlsym APIs under the AIX operating * system, to enable the Tcl "load" command to work. This code was * provided by Jens-Uwe Mager. * |
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * * Note: this file has been altered from the original in a few ways in order * to work properly with Tcl. */ | < < < < < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | * for any results of using the software, alterations are clearly marked * as such, and this notice is not modified. * * Note: this file has been altered from the original in a few ways in order * to work properly with Tcl. */ #include <stdio.h> #include <errno.h> #include <string.h> #include <stdlib.h> #include <sys/types.h> #include <sys/ldr.h> #include <a.out.h> |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "dlopen" and "dlsym" library procedures for dynamic loading. */ #include "tclInt.h" #ifdef NO_DLFCN_H # include "../compat/dlfcn.h" #else # include <dlfcn.h> #endif |
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that works with * Apple's dyld dynamic loading. * Original version of his file (superseded long ago) provided by * Wilfredo Sanchez (wsanchez@apple.com). | > > > > > > > > > > > > > > > > > < < < < < < | 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 | /* * Copyright © 1995 Apple Computer, Inc. * Copyright © 2001-2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that works with * Apple's dyld dynamic loading. * Original version of his file (superseded long ago) provided by * Wilfredo Sanchez (wsanchez@apple.com). */ #include "tclInt.h" #ifndef MODULE_SCOPE # define MODULE_SCOPE extern #endif |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
*/
MODULE_SCOPE int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
| | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
*/
MODULE_SCOPE int
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)
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
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. */
| | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
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)
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadNext.c -- * * This procedure provides a version of the TclLoadFile that works with * NeXTs rld_* dynamic loading. This file provided by Pedja Bogdanovich. */ #include "tclInt.h" #include <mach-o/rld.h> #include <streams/streams.h> /* * Static procedures defined within this file. */ |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
Tcl_LoadHandle newHandle;
struct mach_header *header;
char *fileName;
char *files[2];
const char *native;
int result = 1;
| | | | | 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 |
Tcl_LoadHandle newHandle;
struct mach_header *header;
char *fileName;
char *files[2];
const char *native;
int result = 1;
NXStream *errorStream = NXOpenMemory(0, 0, NX_READWRITE);
fileName = TclGetString(pathPtr);
/*
* 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);
files = {native, NULL};
result = rld_load(errorStream, &header, files, NULL);
if (!result) {
/*
* 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;
if (Tcl_UtfToExternalDStringEx(interp, NULL, fileName, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
files = {native, NULL};
result = rld_load(errorStream, &header, files, NULL);
Tcl_DStringFree(&ds);
}
if (!result) {
char *data;
int len, maxlen;
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclLoadOSF.c -- * * This function provides a version of the TclLoadFile that works under * OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and on * use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. | > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadOSF.c -- * * This function provides a version of the TclLoadFile that works under * OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and on * use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. |
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | * OSF/1 1.3 or later (from OSF) using ELF * includes: MK6, MK7, AD2, AD3 (from OSF RI) * * This approach to things was utter @&^#; thankfully, OSF/1 eventually * supported dlopen(). * * John Robert LoVerso <loverso@freebsd.osf.org> | < < < < < | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | * OSF/1 1.3 or later (from OSF) using ELF * includes: MK6, MK7, AD2, AD3 (from OSF RI) * * This approach to things was utter @&^#; thankfully, OSF/1 eventually * supported dlopen(). * * John Robert LoVerso <loverso@freebsd.osf.org> */ #include "tclInt.h" #include <sys/types.h> #include <loader.h> /* |
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "shl_load" and "shl_findsym" library procedures for dynamic * loading (e.g. for HP machines). | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works with * the "shl_load" and "shl_findsym" library procedures for dynamic * loading (e.g. for HP machines). */ #include <dl.h> #include "tclInt.h" /* * Static functions defined within this file. |
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclSelectNotfy.c -- * * This file contains the implementation of the select()-based generic * Unix notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclSelectNotfy.c -- * * This file contains the implementation of the select()-based generic * Unix notifier, which is the lowest-level part of the Tcl event loop. * This file works together with generic/tclNotify.c. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if (!defined(NOTIFIER_EPOLL) && !defined(NOTIFIER_KQUEUE)) || !TCL_THREADS |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure contains a set of select() masks to track readable,
* writable, and exception conditions.
*/
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
| | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL);
if (filePtr == NULL) {
filePtr = (FileHandler *) Tcl_Alloc(sizeof(FileHandler));
filePtr->fd = fd;
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
| | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
int sigNumber, /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
TCL_UNUSED(void *), /* Notifier data. */
int *flagPtr, /* Flag to mark. */
int value) /* Value of mark. */
{
#if TCL_THREADS
/*
* WARNING:
* This code most likely runs in a signal handler. Thus,
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixChan.c * * Common channel driver for Unix channels based on files, command pipes * and TCP sockets. */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ #undef SUPPORTS_TTY #if defined(HAVE_TERMIOS_H) # define SUPPORTS_TTY 1 # include <termios.h> # ifdef HAVE_SYS_IOCTL_H # include <sys/ioctl.h> # endif /* HAVE_SYS_IOCTL_H */ # ifdef HAVE_SYS_MODEM_H # include <sys/modem.h> # endif /* HAVE_SYS_MODEM_H */ # ifdef FIONREAD # define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int)) # elif defined(FIORDCHK) # define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL) # else # define GETREADQUEUE(fd, int) int = 0 # endif # ifdef TIOCOUTQ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) # else # define GETWRITEQUEUE(fd, int) int = 0 # endif |
| ︙ | ︙ | |||
687 688 689 690 691 692 693 | /* * Transfer dictionary to the DString. Note that we don't do this as * an element as this is an option that can't be retrieved with a * general probe. */ | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
/*
* Transfer dictionary to the DString. Note that we don't do this as
* an element as this is an option that can't be retrieved with a
* general probe.
*/
dictContents = Tcl_GetStringFromObj(dictObj, &dictLength);
Tcl_DStringAppend(dsPtr, dictContents, dictLength);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
}
if (valid) {
return TCL_OK;
|
| ︙ | ︙ |
1 | /* | < < > > > > > > > > > > > > > | 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 | /* * Written by: Zoran Vasiljevic (vasiljevic@users.sourceforge.net). * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixCompat.c */ #include "tclInt.h" #include <errno.h> #include <string.h> /* * See also: SC_BLOCKING_STYLE in unix/tcl.m4 */ |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 | } /* *--------------------------------------------------------------------------- * * TclpGetPwNam -- * | | | | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
}
/*
*---------------------------------------------------------------------------
*
* TclpGetPwNam --
*
* Thread-safe wrappers for getpwnam(). See "man getpwnam" for more
* details.
*
* Results:
* Pointer to struct passwd on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwNam(
const char *name)
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 | } /* *--------------------------------------------------------------------------- * * TclpGetPwUid -- * | | | | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
}
/*
*---------------------------------------------------------------------------
*
* TclpGetPwUid --
*
* Thread-safe wrappers for getpwuid(). See "man getpwuid" for more
* details.
*
* Results:
* Pointer to struct passwd on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwUid(
uid_t uid)
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | #endif /* NEED_PW_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetGrNam -- * | | | | | | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
#endif /* NEED_PW_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetGrNam --
*
* Thread-safe wrappers for getgrnam(). See "man getgrnam" for more
* details.
*
* Results:
* Pointer to struct group on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrNam(
const char *name)
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 | } /* *--------------------------------------------------------------------------- * * TclpGetGrGid -- * | | | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
}
/*
*---------------------------------------------------------------------------
*
* TclpGetGrGid --
*
* Thread-safe wrappers for getgrgid(). See "man getgrgid" for more
* details.
*
* Results:
* Pointer to struct group on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrGid(
gid_t gid)
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | #endif /* NEED_GR_CLEANER */ /* *--------------------------------------------------------------------------- * * TclpGetHostByName -- * | | | | | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
#endif /* NEED_GR_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByName --
*
* Thread-safe wrappers for gethostbyname(). See "man gethostbyname" for
* more details.
*
* Results:
* Pointer to struct hostent on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByName(
const char *name)
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 | } /* *--------------------------------------------------------------------------- * * TclpGetHostByAddr -- * | | | | | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
}
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByAddr --
*
* Thread-safe wrappers for gethostbyaddr(). See "man gethostbyaddr" for
* more details.
*
* Results:
* Pointer to struct hostent on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByAddr(
const char *addr,
|
| ︙ | ︙ | |||
657 658 659 660 661 662 663 | } /* *--------------------------------------------------------------------------- * * CopyGrp -- * | | | | | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 | } /* *--------------------------------------------------------------------------- * * CopyGrp -- * * Copies string fields of the group structure to the private buffer, * honouring the size of the buffer. * * Results: * 0 on success or -1 on error (errno = ERANGE). * * Side effects: * None. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYGRP #define NEED_COPYARRAY 1 #define NEED_COPYSTRING 1 |
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | #endif /* NEED_COPYGRP */ /* *--------------------------------------------------------------------------- * * CopyHostent -- * | | | | | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 | #endif /* NEED_COPYGRP */ /* *--------------------------------------------------------------------------- * * CopyHostent -- * * Copies string fields of the hostent structure to the private buffer, * honouring the size of the buffer. * * Results: * Number of bytes copied on success or -1 on error (errno = ERANGE) * * Side effects: * None * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYHOSTENT #define NEED_COPYSTRING 1 #define NEED_COPYARRAY 1 |
| ︙ | ︙ | |||
792 793 794 795 796 797 798 | #endif /* NEED_COPYHOSTENT */ /* *--------------------------------------------------------------------------- * * CopyPwd -- * | | | | | | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | #endif /* NEED_COPYHOSTENT */ /* *--------------------------------------------------------------------------- * * CopyPwd -- * * Copies string fields of the passwd structure to the private buffer, * honouring the size of the buffer. * * Results: * 0 on success or -1 on error (errno = ERANGE). * * Side effects: * We are not copying the gecos field as it may not be supported on all * platforms. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYPWD #define NEED_COPYSTRING 1 |
| ︙ | ︙ | |||
858 859 860 861 862 863 864 | #endif /* NEED_COPYPWD */ /* *--------------------------------------------------------------------------- * * CopyArray -- * | | | | | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 | #endif /* NEED_COPYPWD */ /* *--------------------------------------------------------------------------- * * CopyArray -- * * Copies array of NULL-terminated or fixed-length strings to the private * buffer, honouring the size of the buffer. * * Results: * Number of bytes copied on success or -1 on error (errno = ERANGE) * * Side effects: * None. * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYARRAY static int CopyArray( |
| ︙ | ︙ | |||
922 923 924 925 926 927 928 | #endif /* NEED_COPYARRAY */ /* *--------------------------------------------------------------------------- * * CopyString -- * | | | | | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 | #endif /* NEED_COPYARRAY */ /* *--------------------------------------------------------------------------- * * CopyString -- * * Copies a NULL-terminated string to the private buffer, honouring the * size of the buffer * * Results: * 0 success or -1 on error (errno = ERANGE) * * Side effects: * None * *--------------------------------------------------------------------------- */ #ifdef NEED_COPYSTRING static int CopyString( |
| ︙ | ︙ | |||
982 983 984 985 986 987 988 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( | | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
* instruction in the four integers designated by 'regsPtr'
*
*----------------------------------------------------------------------
*/
int
TclWinCPUID(
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
/* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
__asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */
"cpuid \n\t"
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixEvent.c -- * * This file implements Unix specific event related routines. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ /* *---------------------------------------------------------------------- * |
| ︙ | ︙ |
1 | /* | < < < < < < < < < < < < < < | | 1 2 3 4 5 6 7 8 9 10 | /* * Copyright © 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * 1. Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the |
| ︙ | ︙ | |||
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" #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ #ifdef HAVE_FTS | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | * 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. */ /* * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Portions of this code were derived from NetBSD source code which has the * following copyright notice: */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixFCmd.c * * This file implements the Unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. */ #include "tclInt.h" #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ #ifdef HAVE_FTS |
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
Tcl_Obj **errorPtr)
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
Tcl_Obj *transPtr;
| | | | 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 |
Tcl_Obj **errorPtr)
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, srcPathPtr);
ret = Tcl_UtfToExternalDStringEx(NULL, NULL,
(transPtr != NULL ? TclGetString(transPtr) : NULL),
-1, 0, &srcString, NULL);
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
if (ret != TCL_OK) {
*errorPtr = srcPathPtr;
} else {
transPtr = Tcl_FSGetTranslatedPath(NULL, destPathPtr);
ret = Tcl_UtfToExternalDStringEx(NULL, NULL,
(transPtr != NULL ? TclGetString(transPtr) : NULL),
-1, TCL_ENCODING_PROFILE_TCL8, &dstString, NULL);
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 | * *--------------------------------------------------------------------------- */ static int CopyFileAtts( #ifdef MAC_OSX_TCL | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 |
*
*---------------------------------------------------------------------------
*/
static int
CopyFileAtts(
#ifdef MAC_OSX_TCL
const char *src, /* Path name of source file (native). */
#else
TCL_UNUSED(const char *) /*src*/,
#endif
const char *dst, /* Path name of target file (native). */
const Tcl_StatBuf *statBufPtr)
/* Stat info for source file */
{
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
Tcl_Size length;
| | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
if (TclGetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
Tcl_Size length;
string = Tcl_GetStringFromObj(attributePtr, &length);
if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
|
| ︙ | ︙ | |||
1582 1583 1584 1585 1586 1587 1588 |
if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
Tcl_Size length;
| | | 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 |
if (TclGetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
Tcl_Size length;
string = Tcl_GetStringFromObj(attributePtr, &length);
if (Tcl_UtfToExternalDStringEx(interp, NULL, string, length, 0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 |
*
*----------------------------------------------------------------------
*/
static int
GetModeFromPermString(
TCL_UNUSED(Tcl_Interp *),
| | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 |
*
*----------------------------------------------------------------------
*/
static int
GetModeFromPermString(
TCL_UNUSED(Tcl_Interp *),
const char *modeStringPtr, /* Permissions string */
mode_t *modePtr) /* pointer to the mode value */
{
mode_t newMode;
mode_t oldMode; /* Storage for the value of the old mode (that
* is passed in), to allow for the chmod style
* manipulation. */
int i, n, who, op, what, op_found, who_found;
/*
* We start off checking for an "rwxrwxrwx" style permissions string
*/
if (strlen(modeStringPtr) != 9) {
goto chmodStyleCheck;
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 |
* normalized. I.e. this is not the index of
* the byte just after the separator. */
{
const char *currentPathEndPosition;
char cur;
Tcl_Size pathLen;
| | | 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 |
* normalized. I.e. this is not the index of
* the byte just after the separator. */
{
const char *currentPathEndPosition;
char cur;
Tcl_Size pathLen;
const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
Tcl_DString ds;
const char *nativePath;
#ifndef NO_REALPATH
char normPath[MAXPATHLEN];
#endif
currentPathEndPosition = path + nextCheckpoint;
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 | * 'Realpath' transforms an empty string into the normalized pwd, * which is the wrong answer. */ return 0; } | | | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
* 'Realpath' transforms an empty string into the normalized pwd,
* which is the wrong answer.
*/
return 0;
}
if (Tcl_UtfToExternalDStringEx(interp, NULL, path, nextCheckpoint, 0, &ds, NULL)) {
Tcl_DStringFree(&ds);
return -1;
}
nativePath = Tcl_DStringValue(&ds);
if (Realpath(nativePath, normPath) != NULL) {
Tcl_Size newNormLen;
|
| ︙ | ︙ | |||
2203 2204 2205 2206 2207 2208 2209 |
Tcl_Size length;
/*
* We should also check against making more than TMP_MAX of these.
*/
if (dirObj) {
| | | | | 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 |
Tcl_Size length;
/*
* We should also check against making more than TMP_MAX of these.
*/
if (dirObj) {
string = Tcl_GetStringFromObj(dirObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &templ, NULL) != TCL_OK) {
return -1;
}
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), TCL_INDEX_NONE); /* INTL: native */
}
TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
string = Tcl_GetStringFromObj(basenameObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) {
Tcl_DStringFree(&tmp);
return -1;
}
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, "tcl");
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
string = Tcl_GetStringFromObj(extensionObj, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, length, 0, &tmp, NULL) != TCL_OK) {
Tcl_DStringFree(&templ);
return -1;
}
TclDStringAppendDString(&templ, &tmp);
fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
|
| ︙ | ︙ | |||
2484 2485 2486 2487 2488 2489 2490 | * The readonly attribute of the file is changed. * *--------------------------------------------------------------------------- */ static int SetUnixFileAttributes( | | | | | | 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 |
* The readonly attribute of the file is changed.
*
*---------------------------------------------------------------------------
*/
static int
SetUnixFileAttributes(
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 (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
int yesNo, fileAttributes, old;
WCHAR *winPath;
if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. */ #include "tclInt.h" #include "tclFileSystem.h" static int NativeMatchType(Tcl_Interp *interp, const char* nativeEntry, const char* nativeName, Tcl_GlobTypeData *types); |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
Tcl_Obj *obj;
if (argv0 == NULL) {
return;
}
Tcl_DStringInit(&buffer);
name = argv0;
| > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
Tcl_Obj *obj;
int status;
if (argv0 == NULL) {
return;
}
Tcl_DStringInit(&buffer);
name = argv0;
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
gotName:
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
| | > > > > | 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
gotName:
#ifdef DJGPP
if (name[1] == ':')
#else
if (name[0] == '/')
#endif
{
status = Tcl_ExternalToUtfDStringEx(NULL, NULL, name, TCL_INDEX_NONE
,TCL_ENCODING_PROFILE_STRICT ,&utfName ,NULL);
if (status != TCL_OK) {
Tcl_Panic("%s {unable to encode value of path}" ,"TclpFindExecutable");
}
TclSetObjNameOfExecutable(Tcl_DStringToObj(&utfName), NULL);
goto done;
}
if (TclpGetCwd(NULL, &cwd) == NULL) {
TclNewObj(obj);
TclSetObjNameOfExecutable(obj, NULL);
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
name += 2;
}
Tcl_DStringInit(&nameString);
Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE);
Tcl_DStringFree(&buffer);
| | | > > > | | > > > > | 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 |
name += 2;
}
Tcl_DStringInit(&nameString);
Tcl_DStringAppend(&nameString, name, TCL_INDEX_NONE);
Tcl_DStringFree(&buffer);
status = Tcl_UtfToExternalDStringEx(NULL, NULL, Tcl_DStringValue(&cwd),
Tcl_DStringLength(&cwd), TCL_ENCODING_PROFILE_STRICT, &buffer, NULL);
if (status != TCL_OK) {
Tcl_Panic("%s {unable to encode value of cwd}" ,"TclpFindExecutable");
}
if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') {
TclDStringAppendLiteral(&buffer, "/");
}
Tcl_DStringFree(&cwd);
TclDStringAppendDString(&buffer, &nameString);
Tcl_DStringFree(&nameString);
status = Tcl_ExternalToUtfDStringEx(NULL, NULL, Tcl_DStringValue(&buffer)
, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_STRICT, &utfName, NULL);
if (status != TCL_OK) {
Tcl_Panic("%s {unable to encode value of executable name}"
,"TclpFindExecutable");
}
TclSetObjNameOfExecutable(Tcl_DStringToObj(&utfName), NULL);
done:
Tcl_DStringFree(&buffer);
}
#endif
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | } } /* * Now open the directory for reading and iterate over the contents. */ | | > | | 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 |
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
if (Tcl_UtfToExternalDStringEx(interp, NULL, dirName, TCL_INDEX_NONE,
0, &ds, NULL) != TCL_OK) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
native = Tcl_DStringValue(&ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = TclOSopendir(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)));
}
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ | | | | > | 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 |
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
if (Tcl_ExternalToUtfDStringEx(interp, NULL, entryPtr->d_name,
TCL_INDEX_NONE, 0, &utfDs, NULL) != TCL_OK) {
matchResult = -1;
break;
}
utfname = Tcl_DStringValue(&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name,
TCL_INDEX_NONE);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 | * None. * *---------------------------------------------------------------------- */ static int NativeMatchType( | | | | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeMatchType(
Tcl_Interp *interp, /* Interpreter to receive errors. */
const char *nativeEntry, /* Native path to check. */
const char *nativeName, /* Native filename to check. */
Tcl_GlobTypeData *types) /* Type description to match against. */
{
Tcl_StatBuf buf;
if (types == NULL) {
/*
* Simply check for the file's existence, but do it with lstat, in
* case it is a link to a file which doesn't exist (since that case
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
const char *native;
| | > | > | 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 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of user's home directory. */
{
struct passwd *pwPtr;
Tcl_DString ds;
const char *native;
if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
native = Tcl_DStringValue(&ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
return NULL;
}
if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE,
0, bufferPtr, NULL) != TCL_OK) {
return NULL;
} else {
return Tcl_DStringValue(bufferPtr);
}
}
/*
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
| | > | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, 0,
bufferPtr, NULL) != TCL_OK) {
return NULL;
}
return Tcl_DStringValue(bufferPtr);
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
{
#ifndef DJGPP
char link[MAXPATHLEN];
Tcl_Size length;
const char *native;
Tcl_DString ds;
| | > | > | 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 |
{
#ifndef DJGPP
char link[MAXPATHLEN];
Tcl_Size length;
const char *native;
Tcl_DString ds;
if (Tcl_UtfToExternalDStringEx(NULL, NULL, path, TCL_INDEX_NONE, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
native = Tcl_DStringValue(&ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (length < 0) {
return NULL;
}
if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, length, 0, linkPtr,
NULL) == TCL_OK) {
return Tcl_DStringValue(linkPtr);
}
#endif /* !DJGPP */
return NULL;
}
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
| | | > | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 |
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = Tcl_GetStringFromObj(transPtr, &length);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, target, length, 0, &ds,
NULL) != TCL_OK) {
Tcl_DStringFree(&ds);
return NULL;
}
target = Tcl_DStringValue(&ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
| | > | > | 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link,
sizeof(link));
if (length < 0) {
return NULL;
}
if (Tcl_ExternalToUtfDStringEx(NULL, NULL, link, (size_t)length, 0,
&ds, NULL) != TCL_OK) {
return NULL;
}
linkPtr = Tcl_DStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
return linkPtr;
}
}
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 1091 |
*/
Tcl_Obj *
TclpNativeToNormalized(
void *clientData)
{
Tcl_DString ds;
| > | > > > > > | 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 |
*/
Tcl_Obj *
TclpNativeToNormalized(
void *clientData)
{
Tcl_DString ds;
int status;
status = Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData,
TCL_INDEX_NONE, TCL_ENCODING_PROFILE_STRICT, &ds, NULL);
if (status != TCL_OK) {
Tcl_Panic("%s {unable to encode value}" ,"TclpNativeToNormalized");
}
return Tcl_DStringToObj(&ds);
}
/*
*---------------------------------------------------------------------------
*
* TclNativeCreateNativeRep --
|
| ︙ | ︙ | |||
1138 1139 1140 1141 1142 1143 1144 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
| | | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
if (Tcl_UtfToExternalDStringEx(NULL, NULL, str, len, 0, &ds, NULL) != TCL_OK) {
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation. * All rights reserved. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. */ #include "tclInt.h" #ifdef HAVE_LANGINFO # include <langinfo.h> # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 /* Support for weakly importing nl_langinfo on Darwin. */ # define WEAK_IMPORT_NL_LANGINFO |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
union {
unsigned int dwOemId;
struct {
int wProcessorArchitecture;
int wReserved;
};
};
| | | | | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
union {
unsigned int dwOemId;
struct {
int wProcessorArchitecture;
int wReserved;
};
};
unsigned int dwPageSize;
void *lpMinimumApplicationAddress;
void *lpMaximumApplicationAddress;
void *dwActiveProcessorMask;
unsigned int dwNumberOfProcessors;
unsigned int dwProcessorType;
unsigned int dwAllocationGranularity;
int wProcessorLevel;
int wProcessorRevision;
} SYSTEM_INFO;
typedef struct {
unsigned int dwOSVersionInfoSize;
unsigned int dwMajorVersion;
unsigned int dwMinorVersion;
unsigned int dwBuildNumber;
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
/*
* Note lengthPtr is (size_t *) which is unsigned so cannot
* pass directly to Tcl_GetStringFromObj.
* TODO - why is the type size_t anyways?
*/
Tcl_Size length;
| | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
/*
* Note lengthPtr is (size_t *) which is unsigned so cannot
* pass directly to Tcl_GetStringFromObj.
* TODO - why is the type size_t anyways?
*/
Tcl_Size length;
str = Tcl_GetStringFromObj(pathPtr, &length);
*lengthPtr = length;
*valuePtr = (char *)Tcl_Alloc(length + 1);
memcpy(*valuePtr, str, length + 1);
Tcl_DecrRefCount(pathPtr);
}
/*
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 |
CFRelease(frameworksURL);
}
}
}
#endif /* HAVE_COREFOUNDATION */
p = pkgPath;
while ((q = strchr(p, ':')) != NULL) {
| | | | 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
CFRelease(frameworksURL);
}
}
}
#endif /* HAVE_COREFOUNDATION */
p = pkgPath;
while ((q = strchr(p, ':')) != NULL) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, q - p));
p = q + 1;
}
if (*p) {
Tcl_ListObjAppendElement(NULL, pkgListObj, Tcl_NewStringObj(p, -1));
}
Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_pkgPath", -1), NULL, pkgListObj, TCL_GLOBAL_ONLY);
{
/* Some platforms build configure scripts expect ~ expansion so do that */
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 |
GetSystemInfo(&sysInfo);
if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
osInfo.dwMajorVersion = 11;
}
Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY);
| | > | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
GetSystemInfo(&sysInfo);
if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
osInfo.dwMajorVersion = 11;
}
Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY);
snprintf(buffer, sizeof(buffer), "%d.%d",
osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
Tcl_DStringFree(&ds);
}
/*
* Define what the platform PATH separator is. [TIP #315]
*/
| | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
Tcl_DStringFree(&ds);
}
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform", "pathSeparator", ":", TCL_GLOBAL_ONLY);
}
/*
*----------------------------------------------------------------------
*
* TclpFindVariable --
*
|
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * Copyright © 2016 Lucio Andrés Illanes Albornoz <l.illanes@gmx.de> * Copyright © 2021 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixNotfy.c -- * * This file contains subroutines shared by all notifier backend * implementations on *nix platforms. It is *included* by the epoll, * kqueue and select notifier implementation files. */ #include <poll.h> #include "tclInt.h" /* * Static routines defined in this file. */ |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixPipe.c -- * * This file implements the UNIX-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. */ #include "tclInt.h" #ifdef HAVE_POSIX_SPAWNP # if defined(HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDDUP2) \ && defined(HAVE_POSIX_SPAWNATTR_SETFLAGS) \ && !defined(HAVE_VFORK) # include <unistd.h> |
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * The file is closed. * *---------------------------------------------------------------------- */ int TclpCloseFile( | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
* The file is closed.
*
*----------------------------------------------------------------------
*/
int
TclpCloseFile(
TclFile file) /* The file to close. */
{
int fd = GetFd(file);
/*
* Refuse to close the fds for stdin, stdout and stderr.
*/
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
size_t argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
* call). Additional arguments have not been
* converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 | * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && | | | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 |
* Set up stdio file handles for the child process.
*/
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)))) {
snprintf(errSpace, sizeof(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);
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( | | | 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
PipeBlockModeProc(
void *instanceData, /* Pipe state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (psPtr->inFile
|
| ︙ | ︙ | |||
1039 1040 1041 1042 1043 1044 1045 | * Closes the command pipeline channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
* Closes the command pipeline channel.
*
*----------------------------------------------------------------------
*/
static int
PipeClose2Proc(
void *instanceData, /* The pipe to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
PipeState *pipePtr = (PipeState *)instanceData;
Tcl_Channel errChan;
int errorCode, result;
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
* routine.
*/
if (pipePtr->errorFile) {
errChan = Tcl_MakeFileChannel(
INT2PTR(GetFd(pipePtr->errorFile)),
TCL_READABLE);
| < < | 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 |
* routine.
*/
if (pipePtr->errorFile) {
errChan = Tcl_MakeFileChannel(
INT2PTR(GetFd(pipePtr->errorFile)),
TCL_READABLE);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeInputProc(
void *instanceData, /* Pipe state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
PipeState *psPtr = (PipeState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeOutputProc(
void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
PipeState *psPtr = (PipeState *)instanceData;
int written;
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
PipeWatchProc(
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
Tcl_Channel channel = (Tcl_Channel)clientData;
Tcl_NotifyChannel(channel, mask);
}
static void
PipeWatchProc(
void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
PipeState *psPtr = (PipeState *)instanceData;
int newmask;
|
| ︙ | ︙ | |||
1296 1297 1298 1299 1300 1301 1302 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PipeGetHandleProc(
void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (direction == TCL_READABLE && psPtr->inFile) {
*handlePtr = INT2PTR(GetFd(psPtr->inFile));
return TCL_OK;
}
|
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixPort.h -- * * This header file handles porting issues that occur because of * differences between systems. It reads in UNIX-related header files and * sets up UNIX-related macros for Tcl's UNIX core. It should be the only * file that contains #ifdefs to handle different flavors of UNIX. This * file sets up the union of all UNIX-related things needed by any of the * Tcl core files. This file depends on configuration #defines such as * HAVE_SYS_PARAM_H that are set up by the "configure" script. * * Much of the material in this file was originally contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. | > > > > > > > > > > > > > > > > > < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * Copyright (c) 1991-1994 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixPort.h -- * * This header file handles porting issues that occur because of * differences between systems. It reads in UNIX-related header files and * sets up UNIX-related macros for Tcl's UNIX core. It should be the only * file that contains #ifdefs to handle different flavors of UNIX. This * file sets up the union of all UNIX-related things needed by any of the * Tcl core files. This file depends on configuration #defines such as * HAVE_SYS_PARAM_H that are set up by the "configure" script. * * Much of the material in this file was originally contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. */ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT /* *--------------------------------------------------------------------------- |
| ︙ | ︙ | |||
232 233 234 235 236 237 238 | #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ | | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 | #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ (((*((int *) &(stat)))) && ((*((int *) &(stat))) \ == ((*((int *) &(stat))) & 0x00FF))) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | | | 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 | /* * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. */ #include "tclInt.h" #include <netinet/tcp.h> /* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. */ #define SET_BITS(var, bits) ((var) |= (bits)) #define CLEAR_BITS(var, bits) ((var) &= ~(bits)) #define GOT_BITS(var, bits) (((var) & (bits)) != 0) /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) #define SOCK_TEMPLATE "sock%" TCL_Z_MODIFIER "x" #undef SOCKET /* Possible conflict with win32 SOCKET */ /* * This is needed to comply with the strict aliasing rules of GCC, but it also * simplifies casting between the different sockaddr types. */ |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 |
* 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. */
| | | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
* 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 connectError; /* Cache SO_ERROR of async socket. */
int cachedBlocking; /* Cache blocking mode of async socket. */
};
/*
* These bits may be OR'ed together into the "flags" field of a TcpState
* structure.
*/
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
char host[NI_MAXHOST], port[NI_MAXSERV];
struct addrinfo *ai;
for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
getnameinfo(ai->ai_addr, ai->ai_addrlen,
host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
| | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
char host[NI_MAXHOST], port[NI_MAXSERV];
struct addrinfo *ai;
for (ai = addrlist; ai != NULL; ai = ai->ai_next) {
getnameinfo(ai->ai_addr, ai->ai_addrlen,
host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
fprintf(stderr, "%s: %s:%s\n", prefix, host, port);
}
}
#endif
/*
* ----------------------------------------------------------------------
*
* InitializeHostName --
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ static int TcpBlockModeProc( | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
* Sets the device into blocking or nonblocking mode.
*
* ----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
void *instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_BLOCKING) {
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int TcpInputProc( | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
void *instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpOutputProc(
void *instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int written;
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 | * Closes the socket of the channel. * *---------------------------------------------------------------------- */ static int TcpCloseProc( | | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
* Closes the socket of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
int errorCode = 0;
TcpFdList *fds;
/*
|
| ︙ | ︙ | |||
650 651 652 653 654 655 656 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
* Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *),
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
static void
TcpWatchProc(
| | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
static void
TcpWatchProc(
void *instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (statePtr->acceptProc != NULL) {
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 | * None. * * ---------------------------------------------------------------------- */ static int TcpGetHandleProc( | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 |
* None.
*
* ----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->fds.fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 | * attempt has succeeded or failed. * * ---------------------------------------------------------------------- */ static void TcpAsyncCallback( | | | | | | 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 |
* attempt has succeeded or failed.
*
* ----------------------------------------------------------------------
*/
static void
TcpAsyncCallback(
void *clientData, /* The socket state. */
TCL_UNUSED(int) /*mask*/)
{
TcpConnect(NULL, (TcpState *)clientData);
}
/*
* ----------------------------------------------------------------------
*
* TcpConnect --
*
* This function opens a new socket in client mode.
*
* Results:
* TCL_OK, if the socket was successfully connected or an asynchronous
* connection is in progress. If an error occurs, TCL_ERROR is returned
* and an error message is left in interp.
*
* Side effects:
* Opens a socket.
*
* Remarks:
* A single host name may resolve to more than one IP address, e.g. for
* an IPv4/IPv6 dual stack host. For handling asynchronously connecting
|
| ︙ | ︙ | |||
1569 1570 1571 1572 1573 1574 1575 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( | | | 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
TCL_READABLE | TCL_WRITABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 | * None. * *---------------------------------------------------------------------- */ void * TclpMakeTcpClientChannelMode( | | | 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 |
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpMakeTcpClientChannelMode(
void *sock, /* The socket to wrap up into a channel. */
int mode) /* OR'ed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState));
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 |
Tcl_Channel
Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
| | | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
Tcl_Channel
Tcl_OpenTcpServerEx(
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
int backlog, /* Length of OS listen backlog queue. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
int status = 0, sock = -1, optvalue, port, chosenport;
struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */
|
| ︙ | ︙ | |||
1895 1896 1897 1898 1899 1900 1901 | * connection acceptance mechanism. * *---------------------------------------------------------------------- */ static void TcpAccept( | | | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
* connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
void *data, /* Callback token. */
TCL_UNUSED(int) /*mask*/)
{
TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > > | | < | 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 | /* * Copyright © 1996-1997 Sun Microsystems, Inc. * Copyright © 1998 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixTest.c -- * * Contains platform specific test commands for the Unix platform. */ #ifndef USE_TCL_STUBS # undef BUILD_tcl # undef STATIC_BUILD # define USE_TCL_STUBS #endif #include "tclInt.h" /* * The headers are needed for the testalarm command that verifies the use of * SA_RESTART in signal handlers. |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1991-1994 The Regents of the University of California. * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixThrd.c -- * * This file implements the UNIX-specific thread support. */ #include "tclInt.h" #if TCL_THREADS /* * TIP #509. Ensures that Tcl's mutexes are reentrant. * |
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
| | | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
size_t stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
pthread_attr_t attr;
pthread_t theThread;
int result;
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclUnixTime.c -- * * Contains Unix specific versions of Tcl functions that obtain time * values from the operating system. */ #include "tclInt.h" #if defined(TCL_WIDE_CLICKS) && defined(MAC_OSX_TCL) #include <mach/mach_time.h> #endif /* * Static functions declared in this file. |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclXtNotify.c -- * * This file contains the notifier driver implementation for the Xt * intrinsics. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include <X11/Intrinsic.h> #include "tclInt.h" /* |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
* time FileHandlerEventProc was called for
* this file. */
XtInputId read; /* Xt read callback handle. */
XtInputId write; /* Xt write callback handle. */
XtInputId except; /* Xt exception callback handle. */
Tcl_FileProc *proc; /* Procedure to call, in the style of
* Tcl_CreateFileHandler. */
| | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
* time FileHandlerEventProc was called for
* this file. */
XtInputId read; /* Xt read callback handle. */
XtInputId write; /* Xt write callback handle. */
XtInputId except; /* Xt exception callback handle. */
Tcl_FileProc *proc; /* Procedure to call, in the style of
* Tcl_CreateFileHandler. */
void *clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure is what is added to the Tcl event queue when file
* handlers are ready to fire.
*/
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ static void SetTimer( | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
* Replaces any previous timer.
*
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
unsigned long timeout;
if (!initialized) {
InitNotifier();
}
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Procedure to call for each selected
* event. */
| | | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Procedure to call for each selected
* event. */
void *clientData) /* Arbitrary data to pass to proc. */
{
FileHandler *filePtr;
if (!initialized) {
InitNotifier();
}
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 | * Queues file events that are detected by the select. * *---------------------------------------------------------------------- */ static int WaitForEvent( | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 |
* 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();
}
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclXtTest.c -- * * Contains commands for Xt notifier specific tests on Unix. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include <X11/Intrinsic.h> #include "tcl.h" static Tcl_ObjCmdProc TesteventloopCmd; |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it # is a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it # is a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. VERSION = @TCL_VERSION@ |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | # 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@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 | < < < < < | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | # 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@ -DMP_FIXED_CUTOFFS -D__USE_MINGW_ANSI_STDIO=0 # 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@ |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
TCL_VFS_ROOT = libtcl.vfs
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX}
| < < | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
TCL_VFS_ROOT = libtcl.vfs
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX}
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX}
REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\
package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}]
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}
TCLTEST_OBJS = \
tclTest.$(OBJEXT) \
tclTestABSList.$(OBJEXT) \
tclTestObj.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
tclThreadTest.$(OBJEXT) \
tclWinTest.$(OBJEXT)
GENERIC_OBJS = \
regcomp.$(OBJEXT) \
regexec.$(OBJEXT) \
regfree.$(OBJEXT) \
regerror.$(OBJEXT) \
tclAlloc.$(OBJEXT) \
tclArithSeries.$(OBJEXT) \
tclAssembly.$(OBJEXT) \
tclAsync.$(OBJEXT) \
tclBasic.$(OBJEXT) \
tclBinary.$(OBJEXT) \
tclCkalloc.$(OBJEXT) \
tclClock.$(OBJEXT) \
| > < | 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 |
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}
TCLTEST_OBJS = \
tclTest.$(OBJEXT) \
tclTestABSList.$(OBJEXT) \
tclTestObj.$(OBJEXT) \
tclTestObjInterface.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
tclThreadTest.$(OBJEXT) \
tclWinTest.$(OBJEXT)
GENERIC_OBJS = \
regcomp.$(OBJEXT) \
regexec.$(OBJEXT) \
regfree.$(OBJEXT) \
regerror.$(OBJEXT) \
tclAlloc.$(OBJEXT) \
tclArithSeries.$(OBJEXT) \
tclAssembly.$(OBJEXT) \
tclAsync.$(OBJEXT) \
tclBasic.$(OBJEXT) \
tclBinary.$(OBJEXT) \
tclCkalloc.$(OBJEXT) \
tclClock.$(OBJEXT) \
tclCmdAH.$(OBJEXT) \
tclCmdIL.$(OBJEXT) \
tclCmdMZ.$(OBJEXT) \
tclCompCmds.$(OBJEXT) \
tclCompCmdsGR.$(OBJEXT) \
tclCompCmdsSZ.$(OBJEXT) \
tclCompExpr.$(OBJEXT) \
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 | tclProc.$(OBJEXT) \ tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ | < | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | tclProc.$(OBJEXT) \ tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ tclThreadStorage.$(OBJEXT) \ tclTimer.$(OBJEXT) \ |
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
tcltest.sh: tcltest.cmd
tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
| | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
tcltest.sh: tcltest.cmd
tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
libraries:
doc:
tclzipfile: ${TCL_ZIP_FILE}
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest
| < < < < < < < < | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinReg.${OBJEXT}: tclWinReg.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
| < < < < < < | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinReg.${OBJEXT}: tclWinReg.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinDde.${OBJEXT}: tclWinDde.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclAppInit.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
|
| ︙ | ︙ | |||
877 878 879 880 881 882 883 |
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
| < < < < < < < < | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo Installing $(DDE_LIB_FILE); \
$(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
$(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \
fi
install-libraries: libraries install-tzdata install-msgs
@for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 | $(TCL_EXE) "$(TOOL_DIR_NATIVE)/makeHeader.tcl" \ "$(TOOL_DIR_NATIVE)/tclOOScript.tcl" \ "$(GENERIC_DIR_NATIVE)/tclOOScript.h" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool | | | 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 | $(TCL_EXE) "$(TOOL_DIR_NATIVE)/makeHeader.tcl" \ "$(TOOL_DIR_NATIVE)/tclOOScript.tcl" \ "$(GENERIC_DIR_NATIVE)/tclOOScript.h" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl9.* # tk8.* up two directories from the TOOL_DIR. # TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1996 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * cat.c -- * * Program used when testing tclWinPipe.c */ #ifdef TCL_BROKEN_MAINARGS /* On mingw32 and cygwin this doesn't work */ # undef UNICODE # undef _UNICODE #endif #include <stdio.h> |
| ︙ | ︙ |
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
1 2 3 4 5 6 7 8 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT([tcl],[9.0]) AC_CONFIG_SRCDIR([../generic/tcl.h]) AC_PREREQ([2.69]) | > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | #! /bin/bash -norc # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT([tcl],[9.0]) AC_CONFIG_SRCDIR([../generic/tcl.h]) AC_PREREQ([2.69]) |
| ︙ | ︙ |
1 2 3 4 5 6 7 | #------------------------------------------------------------- -*- makefile -*- # # Microsoft Visual C++ makefile for building Tcl with nmake # # 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 | # 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. # Copyright (c) 2017 Ashok P. Nadkarni # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------- -*- makefile -*- # # Microsoft Visual C++ makefile for building Tcl with nmake # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # # For MACRODEF, see TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) # or examine Sections 7-9 in rules.vc. # |
| ︙ | ︙ | |||
227 228 229 230 231 232 233 234 235 236 237 238 239 240 | TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ $(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 \ $(TMP_DIR)\tclTestABSList.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif | > | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 | TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestObjInterface.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ $(TMP_DIR)\tclTestABSList.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif |
| ︙ | ︙ | |||
250 251 252 253 254 255 256 | $(TMP_DIR)\tclAlloc.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \ $(TMP_DIR)\tclClock.obj \ | < | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | $(TMP_DIR)\tclAlloc.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \ $(TMP_DIR)\tclClock.obj \ $(TMP_DIR)\tclCmdAH.obj \ $(TMP_DIR)\tclCmdIL.obj \ $(TMP_DIR)\tclCmdMZ.obj \ $(TMP_DIR)\tclCompCmds.obj \ $(TMP_DIR)\tclCompCmdsGR.obj \ $(TMP_DIR)\tclCompCmdsSZ.obj \ $(TMP_DIR)\tclCompExpr.obj \ |
| ︙ | ︙ | |||
316 317 318 319 320 321 322 | $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ | < | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 | $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ $(TMP_DIR)\tclThread.obj \ $(TMP_DIR)\tclThreadAlloc.obj \ $(TMP_DIR)\tclThreadJoin.obj \ $(TMP_DIR)\tclThreadStorage.obj \ $(TMP_DIR)\tclTimer.obj \ |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 2002 David Gravereaux. * Copyright (c) 2006 Pat Thoyts * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * ---------------------------------------------------------------------------- * nmakehlp.c -- * * This is used to fix limitations within nmake and the environment. * * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> #ifdef _MSC_VER #pragma comment (lib, "user32.lib") |
| ︙ | ︙ |
1 2 3 4 5 6 7 8 9 10 11 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # | > > > > > > > > > > > > > > | < | < < < < | 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 | # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # Copyright (c) 2017 Ashok P. Nadkarni # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. |
| ︙ | ︙ | |||
856 857 858 859 860 861 862 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else | < < < < < < < < < < < < < < < | 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 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 |
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 | !endif #################################################################### # 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level | < < < < < | 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 | !endif #################################################################### # 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level # Defaults - Permit deprecated functions and warning level 3 WARNINGS = -W3 !if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"] !if [nmakehlp -f $(CHECKS) "nodep"] !message *** Doing nodep check !endif !if [nmakehlp -f $(CHECKS) "fullwarn"] !message *** Doing full warnings check WARNINGS = -W4 !if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -warn:3 |
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCL_ZIP_FILE) | < < < < < < < < < < < < < < < < < < < < < | 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 |
TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe
TCLSH = $(OUT_DIR)\$(TCLSHNAME)
TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
TCLLIB = $(OUT_DIR)\$(TCLLIBNAME)
TCLSCRIPTZIP = $(OUT_DIR)\$(TCL_ZIP_FILE)
TCLSTUBLIBNAME = $(STUBPREFIX).lib
TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)"
!else # !$(DOING_TCL)
!if $(TCLINSTALL) # Building against an installed Tcl
# When building extensions, we need to locate tclsh. Depending on version
# of Tcl we are building against, this may or may not have a "t" suffix.
# Try various possibilities in turn.
TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist("$(TCLSH)")
TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\lib
TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib
TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCL_ZIP_FILE)
TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
TCL_INCLUDES = -I"$(_TCLDIR)\include"
!else # Building against Tcl sources
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!if !exist($(TCLSH))
TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe
!endif
TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
# When building extensions, may be linking against Tcl that does not add
# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
!if !exist("$(TCLIMPLIB)")
TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib
!endif
TCL_LIBRARY = $(_TCLDIR)\library
TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib
TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib
TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCL_ZIP_FILE)
TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif # TCLINSTALL
tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)"
!endif # $(DOING_TCL)
# We need a tclsh that will run on the host machine as part of the build.
# IX86 runs on all architectures.
!ifndef TCLSH_NATIVE
!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)"
TCLSH_NATIVE = $(TCLSH)
!else
!error You must explicitly set TCLSH_NATIVE for cross-compilation
!endif
!endif
# Do the same for Tk and Tk extensions that require the Tk libraries
!if $(DOING_TK) || $(NEED_TK)
WISHNAMEPREFIX = wish
WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe
TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT)
TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT)
TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT)
TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib
!if $(TK_MAJOR_VERSION) == 8
TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
!else
TKSTUBLIBNAME = tkstub.lib
!endif
!if $(DOING_TK)
|
| ︙ | ︙ | |||
1291 1292 1293 1294 1295 1296 1297 | !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) | < < < < < < < < | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 | !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME = $(PRJLIBNAME9) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX).lib PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, # we will generate one from standard template. !if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD) !ifdef RCFILE RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res) |
| ︙ | ︙ | |||
1407 1408 1409 1410 1411 1412 1413 | OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !elseif $(TCL_VERSION) > 86 OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DMP_64BIT !endif !endif | < | < | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 | OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !elseif $(TCL_VERSION) > 86 OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DMP_64BIT !endif !endif OPTDEFINES = $(OPTDEFINES) !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) |
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 | !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif | < < < < < < < < < | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 | !if "$(MACHINE)" == "AMD64" || "$(MACHINE)" == "ARM64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ |
| ︙ | ︙ |
1 2 3 4 5 6 7 | #------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # You may distribute and/or modify this program under the terms of the GNU # Affero General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # See the file "COPYING" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: |
| ︙ | ︙ |
1 | /* | < < < < < < < < > | | | | > > > | > | < > > > > | > | > | 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 | /* * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for tclsh and other Tcl-based applications (without Tk). * Note that this program must be built in Win32 console mode to work * properly. */ #include "tcl.h" #ifdef TCL_TEST extern Tcl_LibraryInitProc Tcltest_Init; extern Tcl_LibraryInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ #if defined(STATIC_BUILD) |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
if (*p == '\\') {
*p = '/';
}
}
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
if (*p == '\\') {
*p = '/';
}
}
#ifdef TCL_LOCAL_MAIN_HOOK
TCL_LOCAL_MAIN_HOOK(&argc, &argv);
#elif (!defined(_WIN32) || defined(UNICODE))
/* New in Tcl 8.7. This doesn't work on Windows without UNICODE */
TclZipfs_AppHook(&argc, &argv);
#endif
Tcl_Main(argc, argv, TCL_LOCAL_APPINIT);
return 0; /* Needed only to prevent compiler warning. */
}
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1996 Sun Microsystems, Inc. * Copyright © 1998-2000 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWin32Dll.c -- * * This file contains the DLL entry point and other low-level bit bashing * code that needs inline assembly. */ #include "tclWinInt.h" #if defined(HAVE_INTRIN_H) # include <intrin.h> #endif /* * The following variables keep track of information about this DLL on a |
| ︙ | ︙ | |||
428 429 430 431 432 433 434 | * instruction in the four integers designated by 'regsPtr' * *---------------------------------------------------------------------- */ int TclWinCPUID( | | | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
* instruction in the four integers designated by 'regsPtr'
*
*----------------------------------------------------------------------
*/
int
TclWinCPUID(
int index, /* Which CPUID value to retrieve. */
int *regsPtr) /* Registers after the CPUID. */
{
int status = TCL_ERROR;
#if defined(HAVE_INTRIN_H) && defined(_WIN64) && defined(HAVE_CPUID)
__cpuid((int *)regsPtr, index);
status = TCL_OK;
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command pipes and * TCP sockets. */ #include "tclWinInt.h" #include "tclIO.h" /* * State flags used in the info structures below. */ |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | static void FileChannelExitHandler(void *clientData); static void FileCheckProc(void *clientData, int flags); static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | static void FileChannelExitHandler(void *clientData); static void FileCheckProc(void *clientData, int flags); static int FileCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int FileEventProc(Tcl_Event *evPtr, int flags); static int FileGetHandleProc(void *instanceData, int direction, void **handlePtr); static int FileGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static ThreadSpecificData *FileInit(void); static int FileInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); |
| ︙ | ︙ | |||
380 381 382 383 384 385 386 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int FileBlockProc( | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
FileBlockProc(
void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 | * Closes the physical channel * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
* Closes the physical channel
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
void *instanceData, /* Pointer to FileInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
FileInfo *fileInfoPtr = (FileInfo *)instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 | /* * This channel exists on the thread local list. It should have * been removed by an earlier Threadaction call, but do that now * since just deallocating fileInfoPtr would leave an deallocated * pointer on the thread local list. */ | | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 |
/*
* This channel exists on the thread local list. It should have
* been removed by an earlier Threadaction call, but do that now
* since just deallocating fileInfoPtr would leave an deallocated
* pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr, TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
Tcl_Free(fileInfoPtr);
return errorCode;
}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | * operations. * *---------------------------------------------------------------------- */ static long long FileWideSeekProc( | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* operations.
*
*----------------------------------------------------------------------
*/
static long long
FileWideSeekProc(
void *instanceData, /* File state. */
long long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD moveMethod;
LONG newPos, newPosHigh;
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 | * Truncates the file, may move file pointers too. * *---------------------------------------------------------------------- */ static int FileTruncateProc( | | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
* Truncates the file, may move file pointers too.
*
*----------------------------------------------------------------------
*/
static int
FileTruncateProc(
void *instanceData, /* File state. */
long long length) /* Length to truncate at. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
/*
* Save where we were...
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
FileInputProc(
void *instanceData, /* File state. */
char *buf, /* Where to store data read. */
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesRead;
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
FileOutputProc(
void *instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesWritten;
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 | * None. * *---------------------------------------------------------------------- */ static void FileWatchProc( | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
* None.
*
*----------------------------------------------------------------------
*/
static void
FileWatchProc(
void *instanceData, /* File state. */
int mask) /* What events to watch for; OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
Tcl_Time blockTime = { 0, 0 };
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileGetHandleProc(
void *instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
#undef STORE_ELEM
return dictObj;
}
static int
FileGetOptionProc(
| | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
#undef STORE_ELEM
return dictObj;
}
static int
FileGetOptionProc(
void *instanceData, /* The file state. */
Tcl_Interp *interp, /* For error reporting. */
const char *optionName, /* What option to read, or NULL for all. */
Tcl_DString *dsPtr) /* Where to write the value read. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
int valid = 0; /* Flag if valid option parsed. */
int len;
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 | /* * Transfer dictionary to the DString. Note that we don't do this as * an element as this is an option that can't be retrieved with a * general probe. */ | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 |
/*
* Transfer dictionary to the DString. Note that we don't do this as
* an element as this is an option that can't be retrieved with a
* general probe.
*/
dictContents = Tcl_GetStringFromObj(dictObj, &dictLength);
Tcl_DStringAppend(dsPtr, dictContents, dictLength);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
}
if (valid) {
return TCL_OK;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel( | | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *rawHandle, /* OS level handle */
int mode) /* OR'ed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
TCLEXCEPTION_REGISTRATION registration;
#endif
char channelName[16 + TCL_INTEGER_SPACE];
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
return (Tcl_Channel) NULL;
}
/*
* Set up the normal channel options for stdio handles.
*/
| | | | 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 |
return (Tcl_Channel) NULL;
}
/*
* Set up the normal channel options for stdio handles.
*/
if (Tcl_SetChannelOption(NULL, channel, "-translation", "auto")!=TCL_OK ||
Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode)!=TCL_OK) {
Tcl_CloseEx(NULL, channel, 0);
return (Tcl_Channel) NULL;
}
return channel;
}
/*
|
| ︙ | ︙ | |||
1668 1669 1670 1671 1672 1673 1674 |
}
}
}
return type;
}
| | | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
}
}
}
return type;
}
/*
*----------------------------------------------------------------------
*
* NativeIsComPort --
*
* Determines if a path refers to a Windows serial port. A simple and
* efficient solution is to use a "name hint" to detect COM ports by
* their filename instead of resorting to a syscall to detect serialness
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2022 Ashok P. Nadkarni * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, and the * "console" channel driver. Windows 7 or later required. */ #ifdef TCL_CONSOLE_DEBUG #undef NDEBUG /* Enable asserts */ #endif #include "tclWinInt.h" #include <assert.h> #include <ctype.h> |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
#endif
/*
* Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1]
* and bufPtr[0]:bufPtr[length - (size-start)].
*/
typedef struct RingBuffer {
| | | | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
#endif
/*
* Ring buffer for storing data. Actual data is from bufPtr[start]:bufPtr[size-1]
* and bufPtr[0]:bufPtr[length - (size-start)].
*/
typedef struct RingBuffer {
char *bufPtr; /* Pointer to buffer storage */
Tcl_Size capacity; /* Size of the buffer in RingBufferChar */
Tcl_Size start; /* Start of the data within the buffer. */
Tcl_Size length; /* Number of RingBufferChar*/
} RingBuffer;
#define RingBufferLength(ringPtr_) ((ringPtr_)->length)
#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity)
#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_))
/*
* The Win32 console API does not support non-blocking I/O in any form. Thus
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 |
*
* Note on reference counting - a ConsoleHandleInfo instance has multiple
* references to it - one each from every channel that is attached to it
* plus one from the console thread itself which also serves as the reference
* from gConsoleHandleInfoList.
*/
typedef struct ConsoleHandleInfo {
| | > | | > | | | > | | | | | | | | | | | | 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 |
*
* Note on reference counting - a ConsoleHandleInfo instance has multiple
* references to it - one each from every channel that is attached to it
* plus one from the console thread itself which also serves as the reference
* from gConsoleHandleInfoList.
*/
typedef struct ConsoleHandleInfo {
struct ConsoleHandleInfo *nextPtr;
/* Process-global list of consoles */
HANDLE console; /* Console handle */
HANDLE consoleThread; /* Handle to thread doing actual i/o on the
* console */
SRWLOCK lock; /* Controls access to this structure.
* Cheaper than CRITICAL_SECTION but note does
* not support recursive locks or Try* style
* attempts.*/
CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */
CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */
RingBuffer buffer; /* Buffer for data transferred between console
* threads and Tcl threads. For input consoles,
* written by the console thread and read by Tcl
* threads. The converse for output threads */
DWORD initMode; /* Initial console mode. */
DWORD lastError; /* An error caused by the last background
* operation. Set to 0 if no error has been
* detected. */
int numRefs; /* See comments above */
int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE
* for output. Only one or the other can be set. */
int flags;
#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */
} ConsoleHandleInfo;
/*
* This structure describes per-instance data for a console based channel.
*
|
| ︙ | ︙ | |||
179 180 181 182 183 184 185 |
HANDLE handle; /* Console handle */
Tcl_ThreadId threadId; /* Id of owning thread */
struct ConsoleChannelInfo *nextWatchingChannelPtr;
/* Pointer to next channel watching events. */
Tcl_Channel channel; /* Pointer to channel structure. */
DWORD initMode; /* Initial console mode. */
int numRefs; /* See comments above */
| | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
HANDLE handle; /* Console handle */
Tcl_ThreadId threadId; /* Id of owning thread */
struct ConsoleChannelInfo *nextWatchingChannelPtr;
/* Pointer to next channel watching events. */
Tcl_Channel channel; /* Pointer to channel structure. */
DWORD initMode; /* Initial console mode. */
int numRefs; /* See comments above */
int permissions; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
int watchMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags */
#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 | /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. It walks the channel list and if any input channel has data | | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | /* *---------------------------------------------------------------------- * * ConsoleSetupProc -- * * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an * event. It walks the channel list and if any input channel has data * available or output channel has space for data, sets the event loop * blocking time to 0 so that it will poll immediately. * * Results: * None. * * Side effects: * Adjusts the block time if needed. * |
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 | * A console reader or writer thread is started. The returned structure * is placed on the active console handler list gConsoleHandleInfoList. * *------------------------------------------------------------------------ */ static ConsoleHandleInfo * AllocateConsoleHandleInfo( | | | | > | | | > > | | | | 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 |
* A console reader or writer thread is started. The returned structure
* is placed on the active console handler list gConsoleHandleInfoList.
*
*------------------------------------------------------------------------
*/
static ConsoleHandleInfo *
AllocateConsoleHandleInfo(
HANDLE consoleHandle, /* Actual handle to console. */
int permissions) /* TCL_READABLE or TCL_WRITABLE */
{
ConsoleHandleInfo *handleInfoPtr;
DWORD consoleMode;
handleInfoPtr = (ConsoleHandleInfo *) Tcl_Alloc(sizeof(*handleInfoPtr));
memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
memset(handleInfoPtr, 0, sizeof(*handleInfoPtr));
handleInfoPtr->console = consoleHandle;
InitializeSRWLock(&handleInfoPtr->lock);
InitializeConditionVariable(&handleInfoPtr->consoleThreadCV);
InitializeConditionVariable(&handleInfoPtr->interpThreadCV);
RingBufferInit(&handleInfoPtr->buffer, CONSOLE_BUFFER_SIZE);
handleInfoPtr->lastError = 0;
handleInfoPtr->permissions = permissions;
handleInfoPtr->numRefs = 1; /* See function header */
if (permissions == TCL_READABLE) {
GetConsoleMode(consoleHandle, &handleInfoPtr->initMode);
consoleMode = handleInfoPtr->initMode;
consoleMode &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
consoleMode |= ENABLE_LINE_INPUT;
SetConsoleMode(consoleHandle, consoleMode);
}
handleInfoPtr->consoleThread = CreateThread(
NULL, /* default security descriptor */
2 * CONSOLE_BUFFER_SIZE, /* Stack size, rounded up to granularity */
permissions == TCL_READABLE
? ConsoleReaderThread
: ConsoleWriterThread,
handleInfoPtr, /* Pass to thread */
0, /* Flags - no special cases */
NULL); /* Don't care about thread id */
if (handleInfoPtr->consoleThread == NULL) {
/* Note - SRWLock and condition variables do not need finalization */
RingBufferClear(&handleInfoPtr->buffer);
Tcl_Free(handleInfoPtr);
return NULL;
}
|
| ︙ | ︙ | |||
2254 2255 2256 2257 2258 2259 2260 | * May modify an option on a console. Sets Error message if needed (by * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleSetOptionProc( | | | 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 |
* May modify an option on a console. Sets Error message if needed (by
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleSetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
|
| ︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int ConsoleGetOptionProc( | | | 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 |
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinDde.c -- * * This file provides functions that implement the "send" command, * allowing commands to be passed from interpreter to interpreter. */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #include <dde.h> #include <ddeml.h> |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 | | > | > | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 TCL_DECLARE_MUTEX(ddeMutex) #if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a, b, c) \ Tcl_WinTCharToUtf((TCHAR *)(a), (b) * sizeof(WCHAR), c) # define Tcl_UtfToWCharDString(a, b, c) \ (WCHAR *)Tcl_WinUtfToTChar(a, b, c) # else # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif #ifndef Tcl_Size # define Tcl_Size int #endif |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
Tcl_Obj *const objv[]);
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
| < < < < < | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
Tcl_Obj *const objv[]);
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
return TCL_ERROR;
}
Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
| < < < < < < < < | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
return TCL_ERROR;
}
Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
/*
*----------------------------------------------------------------------
*
* Dde_SafeInit --
*
* This function initializes the dde command within a safe interp
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
{
int result = Dde_Init(interp);
if (result == TCL_OK) {
Tcl_HideCommand(interp, "dde", "dde");
}
return result;
}
| < < < < < < < < | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
{
int result = Dde_Init(interp);
if (result == TCL_OK) {
Tcl_HideCommand(interp, "dde", "dde");
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Initialize --
*
* Initialize the global DDE instance.
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
*
*----------------------------------------------------------------------
*/
static const WCHAR *
DdeSetServerName(
Tcl_Interp *interp,
| | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
*
*----------------------------------------------------------------------
*/
static const WCHAR *
DdeSetServerName(
Tcl_Interp *interp,
const WCHAR *name, /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
int flags, /* DDE_FLAG_FORCE or 0 */
Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
* incoming Dde eval's */
{
int suffix;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
const WCHAR *actualName;
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 | * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
* The interpreter given by riPtr is unregistered.
*
*----------------------------------------------------------------------
*/
static void
DeleteProc(
void *clientData) /* The interp we are deleting. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
(searchPtr != NULL) && (searchPtr != riPtr);
|
| ︙ | ︙ | |||
1299 1300 1301 1302 1303 1304 1305 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DdeObjCmd( | | | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DdeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* The interp we are sending from */
Tcl_Size objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
{
static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval", NULL};
enum DdeSubcommands {
DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES,
DDE_EVAL
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 |
/*
* Copyright © 1995-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* You may distribute and/or modify this program under the terms of the GNU
* Affero General Public License as published by the Free Software Foundation,
* either version 3 of the License, or (at your option) any later version.
* See the file "COPYING" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* tclWinError.c --
*
* This file contains code for converting from Win32 errors to errno
* errors.
*/
#include "tclInt.h"
/*
* The following table contains the mapping from Win32 errors to errno errors.
*/
static const unsigned char errorTable[] = {
0,
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() */ |
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
Tcl_Obj **errorPtr)
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
Tcl_Obj *normSrcPtr, *normDestPtr;
int ret;
| | | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
Tcl_Obj **errorPtr)
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
Tcl_Obj *normSrcPtr, *normDestPtr;
int ret;
normSrcPtr = Tcl_FSGetNormalizedPath(NULL, srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL, destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
Tcl_UtfToWCharDString(TclGetString(normSrcPtr), TCL_INDEX_NONE, &srcString);
|
| ︙ | ︙ | |||
1529 1530 1531 1532 1533 1534 1535 | * root volumes (drives) formatted as NTFS are declared hidden when * they are not (and cannot be). * * We test for, and fix that case, here. */ Tcl_Size len; | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
* root volumes (drives) formatted as NTFS are declared hidden when
* they are not (and cannot be).
*
* We test for, and fix that case, here.
*/
Tcl_Size len;
const char *str = Tcl_GetStringFromObj(fileName, &len);
if (len < 4) {
if (len == 0) {
/*
* Not sure if this is possible, but we pass it on anyway.
*/
} else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
| | | 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 |
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
pathv = Tcl_GetStringFromObj(elt, &length);
if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
* copying the string literally. Uppercase the drive letter, just
* because it looks better under Windows to do so.
*/
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 | Tcl_IncrRefCount(tempPath); /* * We'd like to call Tcl_FSGetNativePath(tempPath) but that is * likely to lead to infinite loops. */ | | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath) but that is
* likely to lead to infinite loops.
*/
tempString = Tcl_GetStringFromObj(tempPath, &length);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFileW() doesn't like root directories. We would
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 |
/*
* Build the path in writable memory from the user-supplied pieces and
* some defaults. First, the parent temporary directory.
*/
if (dirObj) {
| | | | | 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 |
/*
* Build the path in writable memory from the user-supplied pieces and
* some defaults. First, the parent temporary directory.
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
Tcl_DStringInit(&base);
Tcl_UtfToWCharDString(Tcl_GetString(dirObj), TCL_INDEX_NONE, &base);
if (dirObj->bytes[dirObj->length - 1] != '\\') {
Tcl_UtfToWCharDString("\\", TCL_INDEX_NONE, &base);
}
} else {
useSystemTemp:
Tcl_DStringInit(&base);
Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
}
/*
* Next, the base of the directory name.
*/
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
#define SUFFIX_LENGTH 8
if (basenameObj) {
Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), TCL_INDEX_NONE, &base);
} else {
Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, TCL_INDEX_NONE, &base);
}
Tcl_UtfToWCharDString("_", TCL_INDEX_NONE, &base);
/*
* Now we keep on trying random suffixes until we get one that works
|
| ︙ | ︙ |
1 2 3 4 5 6 7 | /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. */ #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> #include <lm.h> /* For TclpGetUserHome(). */ |
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
| | > | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
REPARSE_MOUNTPOINT_HEADER_SIZE, NULL, 0, &returnedLength,
NULL)) {
/*
* Error setting junction.
*/
Tcl_WinConvertError(GetLastError());
CloseHandle(hFile);
} else {
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
offset = 0;
if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') {
/*
* Check whether this is a mounted volume.
*/
if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer,
| | | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
offset = 0;
if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') {
/*
* Check whether this is a mounted volume.
*/
if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer,
L"\\??\\Volume{", 11) == 0) {
char drive;
/*
* There is some confusion between \??\ and \\?\ which we have
* to fix here. It doesn't seem very well documented.
*/
|
| ︙ | ︙ | |||
602 603 604 605 606 607 608 |
reparseBuffer->MountPointReparseBuffer.PathBuffer);
if (drive != -1) {
char driveSpec[3] = {
'\0', ':', '\0'
};
driveSpec[0] = drive;
| | | | | | | | 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 |
reparseBuffer->MountPointReparseBuffer.PathBuffer);
if (drive != -1) {
char driveSpec[3] = {
'\0', ':', '\0'
};
driveSpec[0] = drive;
retVal = Tcl_NewStringObj(driveSpec, 2);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* This is actually a mounted drive, which doesn't exists as a
* DOS drive letter. This means the path isn't actually a
* link, although we partially treat it like one ('file type'
* will return 'link'), but then the link will actually just
* be treated like an ordinary directory. I don't believe any
* serious inconsistency will arise from this, but it is
* something to be aware of.
*/
goto invalidError;
} else if (wcsncmp(reparseBuffer->MountPointReparseBuffer
.PathBuffer, L"\\\\?\\", 4) == 0) {
/*
* Strip off the prefix.
*/
offset = 4;
} else if (wcsncmp(reparseBuffer->MountPointReparseBuffer
.PathBuffer, L"\\??\\", 4) == 0) {
/*
* Strip off the prefix.
*/
offset = 4;
}
}
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(
reparseBuffer->MountPointReparseBuffer.PathBuffer,
reparseBuffer->MountPointReparseBuffer
.SubstituteNameLength>>1, &ds);
copy = Tcl_DStringValue(&ds) + offset;
len = Tcl_DStringLength(&ds) - offset;
retVal = Tcl_NewStringObj(copy, len);
Tcl_IncrRefCount(retVal);
Tcl_DStringFree(&ds);
return retVal;
}
invalidError:
Tcl_SetErrno(EINVAL);
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 | /* * Match a single file directly. */ DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; Tcl_Size len = 0; | | | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
/*
* Match a single file directly.
*/
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
Tcl_Size len = 0;
const char *str = Tcl_GetStringFromObj(norm, &len);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 | /* * Build up the directory name for searching, including a trailing * directory separator. */ Tcl_DStringInit(&dsOrig); | | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 |
/*
* Build up the directory name for searching, including a trailing
* directory separator.
*/
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
lastChar = dirName[dirLength -1];
if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) {
TclDStringAppendLiteral(&dsOrig, "/");
dirLength++;
}
|
| ︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | * restrictions. Since the ACL tests are more likely wrong than * right, skip them. Moreover, the unix owner access permissions are * usually mapped to the Windows attributes, so if the user is the * file owner then the attrib checks above are correct (as far as they * go). */ | | | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
* restrictions. Since the ACL tests are more likely wrong than
* right, skip them. Moreover, the unix owner access permissions are
* usually mapped to the Windows attributes, so if the user is the
* file owner then the attrib checks above are correct (as far as they
* go).
*/
if(!GetSecurityDescriptorOwner(sdPtr, &pSid, &SidDefaulted) ||
memcmp(GetSidIdentifierAuthority(pSid), &samba_unmapped,
sizeof(SID_IDENTIFIER_AUTHORITY))==0) {
HeapFree(GetProcessHeap(), 0, sdPtr);
return 0; /* Attrib tests say access allowed. */
}
/*
* Perform security impersonation of the user and open the resulting
|
| ︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 | * See chdir() documentation. * *---------------------------------------------------------------------- */ int TclpObjChdir( | | | 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 |
* See chdir() documentation.
*
*----------------------------------------------------------------------
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
nativePath = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
|
| ︙ | ︙ | |||
2049 2050 2051 2052 2053 2054 2055 |
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
| | | 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 |
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
if (GetFileInformationByHandle(fileHandle, &data) != TRUE) {
fileType = GetFileType(fileHandle);
CloseHandle(fileHandle);
if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
Tcl_SetErrno(ENOENT);
return -1;
}
|
| ︙ | ︙ | |||
2516 2517 2518 2519 2520 2521 2522 |
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
| | | | 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize */
int nextCheckpoint) /* offset to start at in pathPtr */
{
char *lastValidPathEnd = NULL;
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds; /* Some workspace. */
|
| ︙ | ︙ | |||
2795 2796 2797 2798 2799 2800 2801 | Tcl_Obj *tmpPathPtr; Tcl_Size len; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE); | | | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 |
Tcl_Obj *tmpPathPtr;
Tcl_Size len;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, TCL_INDEX_NONE);
path = Tcl_GetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
* End of string was reached above.
*/
|
| ︙ | ︙ | |||
2866 2867 2868 2869 2870 2871 2872 | /* * Path of form /foo/bar which is a path in the root directory of the * current volume. */ const char *drive = TclGetString(useThisCwd); | | | | 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 |
/*
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
const char *drive = TclGetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive, 2);
Tcl_AppendToObj(absolutePath, path, TCL_INDEX_NONE);
Tcl_IncrRefCount(absolutePath);
/*
* We have a refCount on the cwd.
*/
} else {
/*
* Path of form C:foo/bar, but this only makes sense if the cwd is
* also on drive C.
*/
Tcl_Size cwdLen;
const char *drive = Tcl_GetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
drive_cur -= ('a' - 'A');
}
if (drive[0] == drive_cur) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
|
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 |
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
*/
if (*copy == '\\') {
| | | | | 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 |
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
*/
if (*copy == '\\') {
if (0 == strncmp(copy, "\\??\\", 4)) {
copy += 4;
len -= 4;
} else if (0 == strncmp(copy, "\\\\?\\", 4)) {
copy += 4;
len -= 4;
}
}
/*
* Ensure we are using forward slashes only.
*/
for (p = copy; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
objPtr = Tcl_NewStringObj(copy, len);
Tcl_DStringFree(&ds);
return objPtr;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
3053 3054 3055 3056 3057 3058 3059 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
| | | 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
if (strlen(str) != (size_t)len) {
/*
* String contains NUL-bytes. This is invalid.
*/
goto done;
|
| ︙ | ︙ | |||
3253 3254 3255 3256 3257 3258 3259 | /* *--------------------------------------------------------------------------- * * TclWinFileOwned -- * * Returns 1 if the specified file exists and is owned by the current | | | | 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 |
/*
*---------------------------------------------------------------------------
*
* TclWinFileOwned --
*
* Returns 1 if the specified file exists and is owned by the current
* user and 0 otherwise. Like the Unix case, the check is made using
* the real process SID, not the effective (impersonation) one.
*
*---------------------------------------------------------------------------
*/
int
TclWinFileOwned(
Tcl_Obj *pathPtr) /* File whose ownership is to be checked */
|
| ︙ | ︙ | |||
3312 3313 3314 3315 3316 3317 3318 |
}
/*
* Free allocations and be done.
*/
if (secd) {
| | | | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 |
}
/*
* Free allocations and be done.
*/
if (secd) {
LocalFree(secd); /* Also frees ownerSid */
}
if (buf) {
Tcl_Free(buf);
}
return (owned != 0); /* Convert non-0 to 1 */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1994-1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. * All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. */ #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* * GetUserNameW() is found in advapi32.dll |
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
| | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
* Look for the library in its source checkout location.
*/
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = Tcl_GetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
*valuePtr = (char *)Tcl_Alloc(length);
memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
/*
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
| | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform", "pathSeparator", ";", TCL_GLOBAL_ONLY);
}
/*
*----------------------------------------------------------------------
*
* TclpFindVariable --
*
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 |
*----------------------------------------------------------------------
*/
Tcl_Size
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
| | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
*----------------------------------------------------------------------
*/
Tcl_Size
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
Tcl_Size *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
Tcl_Size i, length, result = TCL_INDEX_NONE;
const WCHAR *env;
const char *p1, *p2;
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinInt.h -- * * Declarations of Windows-specific shared variables and procedures. */ #ifndef _TCLWININT #define _TCLWININT #include "tclInt.h" #ifdef HAVE_NO_SEH /* |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, const WCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, const WCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); MODULE_SCOPE void TclWinGenerateChannelName(char channelName[], const char *channelTypeName, void *channelImpl); MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT #define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400 |
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclWinLoad.c -- * * This function provides a version of the TclLoadFile that works with * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic * loading. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinLoad.c -- * * This function provides a version of the TclLoadFile that works with * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic * loading. */ #include "tclWinInt.h" /* * Native name of the directory in the native filesystem where DLLs used in * this process are copied prior to loading, and mutex used to protect its |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | */ Tcl_DString ds; /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | */ Tcl_DString ds; /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); Tcl_DStringInit(&ds); nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds); hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); |
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, which * is the lowest-level part of the Tcl event loop. This file works * together with ../generic/tclNotify.c. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * Copyright © 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, which * is the lowest-level part of the Tcl event loop. This file works * together with ../generic/tclNotify.c. */ #include "tclInt.h" /* * The following static indicates whether this module has been initialized. */ |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 | * May dispose of the notifier window and class. * *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( | | | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
* May dispose of the notifier window and class.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeNotifier(
void *clientData) /* Pointer to notifier data. */
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
/*
* Only finalize the notifier if a notifier was installed in the current
* thread; there is a route in which this is not guaranteed to be true
* (when tclWin32Dll.c:DllMain() is called with the flag
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 | * isn't already one pending. * *---------------------------------------------------------------------- */ void TclpAlertNotifier( | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
* isn't already one pending.
*
*----------------------------------------------------------------------
*/
void
TclpAlertNotifier(
void *clientData) /* Pointer to thread data. */
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
/*
* Note that we do not need to lock around access to the hwnd because the
* race condition has no effect since any race condition implies that the
* notifier thread is already awake.
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 | * Replaces any previous timer. * *---------------------------------------------------------------------- */ void TclpSetTimer( | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
* Replaces any previous timer.
*
*----------------------------------------------------------------------
*/
void
TclpSetTimer(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
UINT timeout;
/*
* We only need to set up an interval timer if we're being called from an
* external event loop. If we don't have a window handle then we just
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
TCL_UNUSED(int), /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
| | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
*----------------------------------------------------------------------
*/
int
TclAsyncNotifier(
TCL_UNUSED(int), /* Signal number. */
TCL_UNUSED(Tcl_ThreadId), /* Target thread. */
TCL_UNUSED(void *), /* Notifier data. */
TCL_UNUSED(int *), /* Flag to mark. */
TCL_UNUSED(int)) /* Value of mark. */
{
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 | * Dispatches a message to a window procedure, which could do anything. * *---------------------------------------------------------------------- */ int TclpWaitForEvent( | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
* Dispatches a message to a window procedure, which could do anything.
*
*----------------------------------------------------------------------
*/
int
TclpWaitForEvent(
const Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
MSG msg;
DWORD timeout, result;
int status;
/*
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 2013 Jan Nijtmans. * All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. */ #include "tclInt.h" /* *---------------------------------------------------------------------- * * Tcl_ConsolePanic -- * * Display a message. If a debugger is present, present it directly to |
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinPipe.c -- * * This file implements the Windows-specific exec pipeline functions, the * "pipe" channel driver, and the "pid" Tcl command. */ #include "tclWinInt.h" /* * The following variable is used to tell whether this module has been * initialized. */ |
| ︙ | ︙ | |||
912 913 914 915 916 917 918 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
| | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
size_t argc, /* Number of arguments in following array. */
const char **argv, /* Array of argument strings. argv[0] contains
* the name of the executable converted to
* native format (using the
* Tcl_TranslateFileName call). Additional
* arguments have not been converted. */
TclFile inputFile, /* If non-NULL, gives the file to use as input
* for the child process. If inputFile file is
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 |
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
| | | 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 |
return special;
}
static void
BuildCommandLine(
const char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
size_t argc, /* Number of arguments. */
const char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (WCHAR). */
{
const char *arg, *start, *special, *bspos;
int quote = 0;
size_t i;
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 | * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ static int PipeBlockModeProc( | | | 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 |
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
PipeBlockModeProc(
void *instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
/*
* Pipes on Windows can not be switched between blocking and nonblocking,
|
| ︙ | ︙ | |||
1992 1993 1994 1995 1996 1997 1998 | * Closes the physical channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 |
* Closes the physical channel.
*
*----------------------------------------------------------------------
*/
static int
PipeClose2Proc(
void *instanceData, /* Pointer to PipeInfo structure. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
PipeInfo *pipePtr = (PipeInfo *) instanceData;
Tcl_Channel errChan;
int errorCode, result;
PipeInfo *infoPtr, **nextPtrPtr;
|
| ︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 |
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((void *)filePtr->handle,
TCL_READABLE);
Tcl_Free(filePtr);
| < | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 |
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((void *)filePtr->handle,
TCL_READABLE);
Tcl_Free(filePtr);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids,
pipePtr->pidPtr, errChan);
}
|
| ︙ | ︙ | |||
2163 2164 2165 2166 2167 2168 2169 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 |
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
PipeInputProc(
void *instanceData, /* Pipe state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->readFile;
|
| ︙ | ︙ | |||
2257 2258 2259 2260 2261 2262 2263 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
PipeOutputProc(
void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
DWORD bytesWritten, timeout;
|
| ︙ | ︙ | |||
2405 2406 2407 2408 2409 2410 2411 |
mask = 0;
if ((infoPtr->watchMask & TCL_WRITABLE) &&
(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
mask = TCL_WRITABLE;
}
| | | 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 |
mask = 0;
if ((infoPtr->watchMask & TCL_WRITABLE) &&
(WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
mask = TCL_WRITABLE;
}
if ((infoPtr->watchMask & TCL_READABLE) && (WaitForRead(infoPtr, 0) >= 0)) {
if (infoPtr->readFlags & PIPE_EOF) {
mask = TCL_READABLE;
} else {
mask |= TCL_READABLE;
}
}
|
| ︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 | * None. * *---------------------------------------------------------------------- */ static void PipeWatchProc( | | | 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 |
* None.
*
*----------------------------------------------------------------------
*/
static void
PipeWatchProc(
void *instanceData, /* Pipe state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
PipeInfo **nextPtrPtr, *ptr;
PipeInfo *infoPtr = (PipeInfo *) instanceData;
int oldMask = infoPtr->watchMask;
|
| ︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PipeGetHandleProc(
void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr;
if (direction == TCL_READABLE && infoPtr->readFile) {
filePtr = (WinFile*) infoPtr->readFile;
*handlePtr = (void *)filePtr->handle;
|
| ︙ | ︙ | |||
3216 3217 3218 3219 3220 3221 3222 |
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
| | | 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 |
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
const char *string = Tcl_GetStringFromObj(basenameObj, &length);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
} else {
|
| ︙ | ︙ |
1 2 3 4 5 6 | /* * tclWinPort.h -- * * This header file handles porting issues that occur because of * differences between Windows and Unix. It should be the only * file that contains #ifdefs to handle different flavors of OS. | > > > > > > > > > > > > > > > > < < < < < | 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 | /* * 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinPort.h -- * * This header file handles porting issues that occur because of * differences between Windows and Unix. It should be the only * file that contains #ifdefs to handle different flavors of OS. */ #ifndef _TCLWINPORT #define _TCLWINPORT #if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ |
| ︙ | ︙ | |||
508 509 510 511 512 513 514 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ | | | | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ #define TclpSysAlloc(size) \ ((void*)HeapAlloc(GetProcessHeap(), 0, size)) #define TclpSysFree(ptr) \ (HeapFree(GetProcessHeap(), 0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) \ ((void*)HeapReAlloc(GetProcessHeap(), 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. |
| ︙ | ︙ |
1 | /* | < < < < < < > > > > > > > > > > > > > > > > > | 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 | /* * Copyright (c) 1997 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinReg.c -- * * This file contains the implementation of the "registry" Tcl built-in * command. This command is built as a dynamically loadable extension in * a separate DLL. */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
static DWORD lastType = REG_RESOURCE_LIST;
#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
| | > | > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
static DWORD lastType = REG_RESOURCE_LIST;
#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a, b, c) \
Tcl_WinTCharToUtf((TCHAR *)(a), (b) * sizeof(WCHAR), c)
# define Tcl_UtfToWCharDString(a, b, c) \
(WCHAR *)Tcl_WinUtfToTChar(a, b, c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#ifndef Tcl_Size
# define Tcl_Size int
#endif
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 |
Tcl_Obj *typeObj, REGSAM mode);
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
| < < < < < | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
Tcl_Obj *typeObj, REGSAM mode);
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
}
cmd = Tcl_CreateObjCommand2(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL);
}
| < < < < < < < < | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
}
cmd = Tcl_CreateObjCommand2(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL);
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
* This function removes the registry command.
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
if (cmd != NULL) {
Tcl_DeleteCommandFromToken(interp, cmd);
}
return TCL_OK;
}
| < < < < < < < < < | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
if (cmd != NULL) {
Tcl_DeleteCommandFromToken(interp, cmd);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DeleteCmd --
*
* Cleanup the interp command token so that unloading doesn't try to
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 | * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( | | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
* None.
*
*----------------------------------------------------------------------
*/
static int
RegistryObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Size n = 1, argc;
int index;
REGSAM mode = 0;
const char *errString = NULL;
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
/*
* Enumerate the values under the given subkey until we get an error,
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
| | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
/*
* Enumerate the values under the given subkey until we get an error,
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key, index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
*
*----------------------------------------------------------------------
*/
static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
| | | 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
*
*----------------------------------------------------------------------
*/
static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Size objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
LRESULT result;
DWORD_PTR sendResult;
int timeout = 3000;
Tcl_Size len;
const char *str;
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1999 Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Serial functionality implemented by Rolf.Schroedter@dlr.de */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinSerial.c -- * * This file implements the Windows-specific serial port functions, and * the "serial" channel driver. */ #include "tclWinInt.h" /* * The following variable is used to tell whether this module has been * initialized. */ |
| ︙ | ︙ | |||
850 851 852 853 854 855 856 | * Reads input from the actual channel. * *---------------------------------------------------------------------- */ static int SerialInputProc( | | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
* Reads input from the actual channel.
*
*----------------------------------------------------------------------
*/
static int
SerialInputProc(
void *instanceData, /* Serial state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesRead = 0;
|
| ︙ | ︙ | |||
957 958 959 960 961 962 963 | * Writes output on the actual channel. * *---------------------------------------------------------------------- */ static int SerialOutputProc( | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 |
* Writes output on the actual channel.
*
*----------------------------------------------------------------------
*/
static int
SerialOutputProc(
void *instanceData, /* Serial state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesWritten, timeout;
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | * None. * *---------------------------------------------------------------------- */ static void SerialWatchProc( | | | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
* None.
*
*----------------------------------------------------------------------
*/
static void
SerialWatchProc(
void *instanceData, /* Serial state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
SerialInfo **nextPtrPtr, *ptr;
SerialInfo *infoPtr = (SerialInfo *) instanceData;
int oldMask = infoPtr->watchMask;
|
| ︙ | ︙ | |||
1244 1245 1246 1247 1248 1249 1250 | * None. * *---------------------------------------------------------------------- */ static int SerialGetHandleProc( | | | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
* None.
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
void *instanceData, /* The serial state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
*handlePtr = (void *)infoPtr->handle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 | * May modify an option on a device. * *---------------------------------------------------------------------- */ static int SerialSetOptionProc( | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
* May modify an option on a device.
*
*----------------------------------------------------------------------
*/
static int
SerialSetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 | * reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc( | | | 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 |
* reused at any time subsequent to the call.
*
*----------------------------------------------------------------------
*/
static int
SerialGetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
SerialInfo *infoPtr;
DCB dcb;
size_t len;
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | /* * Copyright © 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. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * ----------------------------------------------------------------------- * The order and naming of functions in this file should minimize * the file diff to tclUnixSock.c. * ----------------------------------------------------------------------- * * General information on how this module works. |
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
TcpState *statePtr = (TcpState *)instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
SOCKET sock;
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
#define HAVE_OPTION(option) \
| | | 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 |
TcpState *statePtr = (TcpState *)instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
SOCKET sock;
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
#define HAVE_OPTION(option) \
((len > 1) && (optionName[1] == option[1]) && \
(strncmp(optionName, option, len) == 0))
/*
* Go one step in async connect
*
* If any error is thrown save it as background error to report eventually
* below.
|
| ︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 |
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* Do one step and save eventual connect error
*/
SetEvent(tsdPtr->socketListLock);
| | | 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 |
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) {
/*
* Do one step and save eventual connect error
*/
SetEvent(tsdPtr->socketListLock);
WaitForConnect(statePtr, NULL);
} else {
/*
* No async connect reenter pending. Just clear event.
*/
CLEAR_BITS(statePtr->readyEvents, FD_CONNECT);
SetEvent(tsdPtr->socketListLock);
|
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinTest.c -- * * Contains commands for platform specific tests on Windows. */ #undef BUILD_tcl #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" |
| ︙ | ︙ |
1 | /* | < < < < > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1998 Sun Microsystems, Inc. * Copyright © 1999 Scriptics Corporation * Copyright © 2008 George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. */ #include "tclWinInt.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 */ |
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
winThreadPtr = (WinThread *)Tcl_Alloc(sizeof(WinThread));
winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc;
winThreadPtr->lpParameter = clientData;
winThreadPtr->fpControl = _controlfp(0, 0);
EnterCriticalSection(&joinLock);
| | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
winThreadPtr = (WinThread *)Tcl_Alloc(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__)
tHandle = (HANDLE) _beginthreadex(NULL, (unsigned)stackSize,
(Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr,
0, (unsigned *)idPtr);
#else
tHandle = CreateThread(NULL, (DWORD)stackSize,
|
| ︙ | ︙ |
1 | /* | < < < < < > > > > > > > > > > > > > > > > | 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 | /* * Copyright © 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * You may distribute and/or modify this program under the terms of the GNU * Affero General Public License as published by the Free Software Foundation, * either version 3 of the License, or (at your option) any later version. * See the file "COPYING" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * tclWinTime.c -- * * Contains Windows specific versions of Tcl functions that obtain time * values from the operating system. */ #include "tclInt.h" /* * Number of samples over which to estimate the performance counter. */ #define SAMPLES 64 |
| ︙ | ︙ |
cannot compute difference between binary files