Index: .fossil-settings/ignore-glob
==================================================================
--- .fossil-settings/ignore-glob
+++ .fossil-settings/ignore-glob
@@ -58,16 +58,14 @@
unix/dltest/*.so
unix/tcl.pc
unix/tclIndex
unix/Tcl-Info.plist
unix/Tclsh-Info.plist
-unix/pkgs8/*
unix/pkgs/*
win/Debug*
win/Release*
win/*.manifest
-win/pkgs8/*
win/pkgs/*
win/coffbase.txt
win/tcl.hpj
win/nmakehlp.out
win/nmhlp-out.txt
Index: .github/workflows/linux-build.yml
==================================================================
--- .github/workflows/linux-build.yml
+++ .github/workflows/linux-build.yml
@@ -14,11 +14,10 @@
runs-on: ubuntu-22.04
strategy:
matrix:
config:
- ""
- - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--disable-zipfs"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
Index: .github/workflows/win-build.yml
==================================================================
--- .github/workflows/win-build.yml
+++ .github/workflows/win-build.yml
@@ -64,11 +64,10 @@
working-directory: win
strategy:
matrix:
config:
- ""
- - "CFLAGS=-DTCL_NO_DEPRECATED=1"
- "--disable-shared"
- "--disable-zipfs"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
Index: .gitignore
==================================================================
--- .gitignore
+++ .gitignore
@@ -54,16 +54,14 @@
unix/autoMkindex.tcl
unix/dltest.marker
unix/dltest/embtest
unix/tcl.pc
unix/tclIndex
-unix/pkgs8/*
unix/pkgs/*
win/Debug*
win/Release*
win/*.manifest
-win/pkgs8/*
win/pkgs/*
win/coffbase.txt
win/tcl.hpj
win/nmakehlp.out
win/nmhlp-out.txt
Index: .travis.yml
==================================================================
--- .travis.yml
+++ .travis.yml
@@ -24,11 +24,10 @@
os: linux
dist: focal
compiler: gcc
env:
- BUILD_DIR=unix
- - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: focal
compiler: gcc
env:
@@ -292,17 +291,10 @@
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- touch generic/tclStubInit.c generic/tclOOStubInit.c generic/tclOOScript.h
- choco install -y make zip
- cd ${BUILD_DIR}
- - name: "Windows/GCC/Shared: NO_DEPRECATED"
- os: windows
- compiler: gcc
- env:
- - BUILD_DIR=win
- - CFGOPT="--enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
- before_install: *makepreinst
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
@@ -327,17 +319,10 @@
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
- - name: "Windows/GCC-x86/Shared: NO_DEPRECATED"
- os: windows
- compiler: gcc
- env:
- - BUILD_DIR=win
- - CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- before_install: *makepreinst
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
ADDED COPYING
Index: COPYING
==================================================================
--- /dev/null
+++ COPYING
@@ -0,0 +1,661 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ 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.
+
+
+ Copyright (C)
+
+ 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 .
+
+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
+.
Index: compat/dlfcn.h
==================================================================
--- compat/dlfcn.h
+++ compat/dlfcn.h
@@ -1,12 +1,6 @@
/*
- * 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 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
@@ -17,10 +11,25 @@
* 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__
Index: compat/fake-rfc2553.c
==================================================================
--- compat/fake-rfc2553.c
+++ compat/fake-rfc2553.c
@@ -24,10 +24,19 @@
* 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
Index: compat/fake-rfc2553.h
==================================================================
--- compat/fake-rfc2553.h
+++ compat/fake-rfc2553.h
@@ -24,10 +24,19 @@
* 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
Index: compat/gettod.c
==================================================================
--- compat/gettod.c
+++ compat/gettod.c
@@ -1,16 +1,28 @@
/*
- * gettod.c --
- *
- * This file provides the gettimeofday function on systems
- * that only have the System V ftime function.
- *
* 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
#undef timezone
Index: compat/mkstemp.c
==================================================================
--- compat/mkstemp.c
+++ compat/mkstemp.c
@@ -6,10 +6,19 @@
* 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
#include
#include
#include
Index: compat/string.h
==================================================================
--- compat/string.h
+++ compat/string.h
@@ -7,10 +7,19 @@
* 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
/*
Index: compat/strncasecmp.c
==================================================================
--- compat/strncasecmp.c
+++ compat/strncasecmp.c
@@ -7,10 +7,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.
+*/
#include "tclPort.h"
/*
* This array is designed for mapping upper and lower case letter together for
Index: compat/waitpid.c
==================================================================
--- compat/waitpid.c
+++ compat/waitpid.c
@@ -9,10 +9,19 @@
* 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
DELETED compat/zlib/win32/zdll.lib
Index: compat/zlib/win32/zdll.lib
==================================================================
--- compat/zlib/win32/zdll.lib
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win32/zlib1.dll
Index: compat/zlib/win32/zlib1.dll
==================================================================
--- compat/zlib/win32/zlib1.dll
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64-arm/libz.dll.a
Index: compat/zlib/win64-arm/libz.dll.a
==================================================================
--- compat/zlib/win64-arm/libz.dll.a
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64-arm/zdll.lib
Index: compat/zlib/win64-arm/zdll.lib
==================================================================
--- compat/zlib/win64-arm/zdll.lib
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64-arm/zlib1.dll
Index: compat/zlib/win64-arm/zlib1.dll
==================================================================
--- compat/zlib/win64-arm/zlib1.dll
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64/libz.dll.a
Index: compat/zlib/win64/libz.dll.a
==================================================================
--- compat/zlib/win64/libz.dll.a
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64/zdll.lib
Index: compat/zlib/win64/zdll.lib
==================================================================
--- compat/zlib/win64/zdll.lib
+++ /dev/null
cannot compute difference between binary files
DELETED compat/zlib/win64/zlib1.dll
Index: compat/zlib/win64/zlib1.dll
==================================================================
--- compat/zlib/win64/zlib1.dll
+++ /dev/null
cannot compute difference between binary files
Index: doc/Access.3
==================================================================
--- doc/Access.3
+++ doc/Access.3
@@ -1,10 +1,17 @@
'\"
'\" 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
Index: doc/AddErrInfo.3
==================================================================
--- doc/AddErrInfo.3
+++ doc/AddErrInfo.3
@@ -2,10 +2,17 @@
'\" 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
Index: doc/Alloc.3
==================================================================
--- doc/Alloc.3
+++ doc/Alloc.3
@@ -1,10 +1,17 @@
'\"
'\" 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
Index: doc/AllowExc.3
==================================================================
--- doc/AllowExc.3
+++ doc/AllowExc.3
@@ -2,10 +2,17 @@
'\" 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
Index: doc/AppInit.3
==================================================================
--- doc/AppInit.3
+++ doc/AppInit.3
@@ -2,10 +2,17 @@
'\" 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
Index: doc/Encoding.3
==================================================================
--- doc/Encoding.3
+++ doc/Encoding.3
@@ -102,13 +102,10 @@
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.
-The flag \fBTCL_ENCODING_STOPONERROR\fR has no effect,
-it only has meaning in Tcl 8.x.
-.PP
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
@@ -544,17 +541,17 @@
.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
+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
@@ -562,11 +559,11 @@
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
+.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
@@ -587,13 +584,13 @@
to be used by OR-ing the \fBflags\fR parameter passed to the function
with at most one of \fBTCL_ENCODING_PROFILE_TCL8\fR,
\fBTCL_ENCODING_PROFILE_STRICT\fR or \fBTCL_ENCODING_PROFILE_REPLACE\fR.
These correspond to the \fBtcl8\fR, \fBstrict\fR and \fBreplace\fR profiles
respectively. If none are specified, a version-dependent default profile is used.
-For Tcl 9.0, the default profile is \fBstrict\fR.
+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
Index: doc/ObjectType.3
==================================================================
--- doc/ObjectType.3
+++ doc/ObjectType.3
@@ -325,29 +325,29 @@
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 \fBTCL_OBJTYPE_V0\fR for compatibility
+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 "ABSTRACT LIST TYPES"
+.SH "INTERFACES"
.PP
-Additional fields in the Tcl_ObjType descriptor allow for control over
-how custom data values can be manipulated using Tcl's List commands
-without converting the value to a List type. This requires the custom
-type to provide functions that will perform the given operation on the
-custom data representation. Not all functions are required. In the
-absence of a particular function (set to NULL), the fallback is to
-allow the internal List operation to perform the operation, most
-likely causing the value type to be converted to a traditional list.
+Additional fields in Tcl_ObjType structure expose interfaces for data types
+that a value may represent. For example, if the list interface functions are
+implemented for a Tcl_ObjType, then Tcl's list procedures use that interface to
+operate on the value as a list. It is not necessary to implement all functions
+for an interface. When a needed function is NULL, a procedure using the
+interface can attempt to convert the internal Tcl_ObjType to one that it can
+work with. For example, a procedure like \fBlndex\fR might attempt to convert
+the internal type of a Tcl_Obj to \fBtclListType\fR.
.SS "SCALAR VALUE TYPES"
.PP
For a custom value type that is scalar or atomic in nature, i.e., not
-a divisible collection, version \fBTCL_OBJTYPE_V1\fR is
-recommended. In this case, List commands will treat the scalar value
-as if it where a list of length 1, and not convert the value to a List
+a divisible collection, version 0 is
+recommended. In this case, List commands treat the scalar value
+as if it where a list of length 1, and do not convert the value to a List
type.
.SS "VERSION 2: ABSTRACT LISTS"
.PP
Version 2, \fBTCL_OBJTYPE_V2\fR, allows full List support when the
functions described below are provided. This allows for script level
Index: doc/Tcl.n
==================================================================
--- doc/Tcl.n
+++ doc/Tcl.n
@@ -3,10 +3,16 @@
'\" 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
Index: doc/abstract.n
==================================================================
--- doc/abstract.n
+++ doc/abstract.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/after.n
==================================================================
--- doc/after.n
+++ doc/after.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/append.n
==================================================================
--- doc/append.n
+++ doc/append.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/array.n
==================================================================
--- doc/array.n
+++ doc/array.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/bgerror.n
==================================================================
--- doc/bgerror.n
+++ doc/bgerror.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/binary.n
==================================================================
--- doc/binary.n
+++ doc/binary.n
@@ -3,10 +3,16 @@
'\" 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
@@ -249,11 +255,11 @@
.PP
.CS
\fB\e254\fR
.CE
.PP
-(i.e. \fB\exAC\fR) by
+(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
@@ -307,11 +313,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\exE0\exE1\exA0\fR
+\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
@@ -334,11 +340,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\exAB\ex00\exDE\exF0\ex98\fR
+\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,
@@ -349,11 +355,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\exBA\ex00\exED\ex0F\ex89\fR
+\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
@@ -371,11 +377,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\ex03\exFD\ex80\ex04\ex02\ex05\fR
+\fB\ex03\exfd\ex80\ex04\ex02\ex05\fR
.CE
.PP
whereas:
.PP
.CS
@@ -397,11 +403,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\ex03\ex00\exFD\exFF\ex02\ex01\fR
+\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
@@ -413,11 +419,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\ex00\ex03\exFF\exFD\ex01\ex02\fR
+\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
@@ -437,11 +443,11 @@
.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
+\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.
@@ -453,11 +459,11 @@
.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
+\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
@@ -518,11 +524,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\exCD\exCC\exCC\ex3F\ex9A\ex99\ex59\ex40\fR
+\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
@@ -544,11 +550,11 @@
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
-\fB\ex9A\ex99\ex99\ex99\ex99\ex99\exF9\ex3F\fR
+\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
@@ -797,11 +803,11 @@
scanned. If \fIcount\fR is omitted, then one hex digit will be
scanned. For example,
.RS
.PP
.CS
-\fBbinary scan\fR \ex07\exC6\ex05\ex1F\ex34 H3H* var1 var2
+\fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2
.CE
.PP
will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and
\fB051f34\fR stored in \fIvar2\fR.
.RE
@@ -848,11 +854,11 @@
\fIcount\fR is omitted, then one 16-bit integer will be scanned. For
example,
.RS
.PP
.CS
-\fBbinary scan\fR \ex05\ex00\ex07\ex00\exF0\exFF s2s* var1 var2
+\fBbinary scan\fR \ex05\ex00\ex07\ex00\exf0\exff s2s* var1 var2
.CE
.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR. Note that the integers returned are signed unless
\fBsu\fR is used in place of \fBs\fR.
@@ -862,11 +868,11 @@
as \fIcount\fR 16-bit integers represented in big-endian byte
order. For example,
.RS
.PP
.CS
-\fBbinary scan\fR \ex00\ex05\ex00\ex07\exFF\exF0 S2S* var1 var2
+\fBbinary scan\fR \ex00\ex05\ex00\ex07\exff\exf0 S2S* var1 var2
.CE
.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
.RE
@@ -887,11 +893,11 @@
\fIcount\fR is omitted, then one 32-bit integer will be scanned. For
example,
.RS
.PP
.CS
-set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exF0\exFF\exFF\exFF
+set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff
\fBbinary scan\fR $str i2i* var1 var2
.CE
.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR. Note that the integers returned are signed unless
@@ -903,11 +909,11 @@
order, or as unsigned if \fBu\fR is placed
immediately after the \fBI\fR. For example,
.RS
.PP
.CS
-set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exFF\exFF\exFF\exF0
+set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0
\fBbinary scan\fR $str I2I* var1 var2
.CE
.PP
will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
@@ -929,11 +935,11 @@
\fIcount\fR is omitted, then one 64-bit integer will be scanned. For
example,
.RS
.PP
.CS
-set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exF0\exFF\exFF\exFF
+set str \ex05\ex00\ex00\ex00\ex07\ex00\ex00\ex00\exf0\exff\exff\exff
\fBbinary scan\fR $str wi* var1 var2
.CE
.PP
will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and
\fB\-16\fR stored in \fIvar2\fR.
@@ -944,11 +950,11 @@
order, or as unsigned if \fBu\fR is placed
immediately after the \fBW\fR. For example,
.RS
.PP
.CS
-set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exFF\exFF\exFF\exF0
+set str \ex00\ex00\ex00\ex05\ex00\ex00\ex00\ex07\exff\exff\exff\exf0
\fBbinary scan\fR $str WI* var1 var2
.CE
.PP
will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR
stored in \fIvar2\fR.
@@ -975,11 +981,11 @@
compiler dependent. For example, on a Windows system running on an
Intel Pentium processor,
.RS
.PP
.CS
-\fBbinary scan\fR \ex3F\exCC\exCC\exCD f var1
+\fBbinary scan\fR \ex3f\excc\excc\excd f var1
.CE
.PP
will return \fB1\fR with \fB1.6000000238418579\fR stored in
\fIvar1\fR.
.RE
@@ -999,11 +1005,11 @@
machine's native representation. For example, on a Windows system
running on an Intel Pentium processor,
.RS
.PP
.CS
-\fBbinary scan\fR \ex9A\ex99\ex99\ex99\ex99\ex99\exF9\ex3F d var1
+\fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1
.CE
.PP
will return \fB1\fR with \fB1.6000000000000001\fR
stored in \fIvar1\fR.
.RE
Index: doc/break.n
==================================================================
--- doc/break.n
+++ doc/break.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/callback.n
==================================================================
--- doc/callback.n
+++ doc/callback.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/catch.n
==================================================================
--- doc/catch.n
+++ doc/catch.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/cd.n
==================================================================
--- doc/cd.n
+++ doc/cd.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/chan.n
==================================================================
--- doc/chan.n
+++ doc/chan.n
@@ -2,10 +2,16 @@
'\" 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.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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
@@ -156,11 +162,11 @@
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.
+\ex7f. A value outside this range results in an error.
.RE
.VS "TCL8.7 TIP656"
.\" OPTION: -profile
.TP
\fB\-profile\fI profile\fR
@@ -594,16 +600,16 @@
If the encoding profile \fBstrict\fR is in effect for the channel, the command
will raise an exception with the POSIX error code \fBEILSEQ\fR if any encoding
errors are encountered in the channel input data. If the channel is in blocking
mode, the error is thrown after advancing the file pointer to the beginning of
the invalid data. The successfully decoded leading portion of the data prior to
-the error location is returned as the value of the \fB\-data\fR key of the error
+the error location is returned as the value of the \fB\-result read\fR key of the error
option dictionary. If the channel is in non-blocking mode, the successfully
decoded portion of data is returned by the command without an error
exception being raised. A subsequent read will start at the invalid data
and immediately raise a \fBEILSEQ\fR POSIX error exception. Unlike the
-blocking channel case, the \fB\-data\fR key is not present in the
+blocking channel case, the \fB\-result read\fR key is not present in the
error option dictionary. In the case of exception thrown due to encoding
errors, it is possible to introspect, and in some cases recover, by
changing the encoding in use. See \fBENCODING ERROR EXAMPLES\fR later.
.RE
.\" METHOD: seek
@@ -891,11 +897,11 @@
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\-data\fR. The file position is advanced on the encoding error
+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]
@@ -902,11 +908,11 @@
file35a65a0
% chan configure $f -encoding utf-8 -profile strict -blocking 1
% catch {chan read $f} e d
1
% set d
--data A -code 1 -level 0
+-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
Index: doc/class.n
==================================================================
--- doc/class.n
+++ doc/class.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/classvariable.n
==================================================================
--- doc/classvariable.n
+++ doc/classvariable.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/clock.n
==================================================================
--- doc/clock.n
+++ doc/clock.n
@@ -99,19 +99,10 @@
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
-\fI\-now\fR
-Instead of \fItimeVal\fR a non-integer option \fI\-now\fR can be used as
-replacement for today, which is simply interpolated to the runt-time as value
-of \fBclock seconds\fR. For example:
-.sp
-\fBclock format -now -f %a; # current day of the week\fR
-.sp
-\fBclock add -now 1 month; # next month\fR
-.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,
@@ -420,16 +411,12 @@
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, \fB%EJ\fR or \fB%Ej\fR format groups,
-representing the Calendar or Astronomical Julian Day Number, that groups
-are used to determine the date.
-Note, that in case of \fB%EJ\fR or \fB%Ej\fR format groups, representing
-the Julian Date with time fraction, this groups may be used to determine
-the date and time.
+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
@@ -563,37 +550,10 @@
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%Ej\fR
-On output, produces a string of digits giving the Astronomical Julian Date or
-Astronomical Julian Day Number (JDN/JD). In opposite to calendar julian day
-\fB%J\fR, it starts the day at noon.
-On input, accepts a string of digits (or floating point with the time fraction)
-and interprets it as an Astronomical Julian Day Number (JDN/JD).
-The Astronomical Julian Date is a count of the number of calendar days
-that have elapsed since 1 January, 4713 BCE of the proleptic
-Julian calendar, which contains also the time fraktion (after floating point).
-The epoch time of 1 January 1970 corresponds to Astronomical JDN 2440587.5.
-This value corresponds the julian day used in sqlite-database, and is the same
-as result of \fBselect julianday(:seconds, 'unixepoch')\fR.
-.IP \fB%EJ\fR
-On output, produces a string of digits giving the Calendar Julian Date.
-In opposite to julian day \fB%J\fR format group, it produces float number.
-In opposite to astronomical julian day \fB%Ej\fR group, it starts at midnight.
-On input, accepts a string of digits (or floating point with the time fraction)
-and interprets it as a Calendar Julian Day Number.
-The Calendar Julian Date is a count of the number of calendar days
-that have elapsed since 1 January, 4713 BCE of the proleptic
-Julian calendar, which contains also the time fraktion (after floating point).
-The epoch time of 1 January 1970 corresponds to Astronomical JDN 2440588.
-.IP \fB%Es\fR
-This affects similar to \fB%s\fR, but in opposition to \fB%s\fR it parses
-or formats local seconds (not the posix seconds).
-Because \fB%s\fR has the same precedence as \fB%s\fR (uniquely determines
-a point in time), it overrides all other input formats.
.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.
@@ -629,11 +589,11 @@
(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 calendar Julian Day Number.
+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.
@@ -750,18 +710,16 @@
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 (this token is optionally applicable on input,
-so the value is not mandatory and can be missing in input).
+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 (token is also like \fB%z\fR optionally applicable on input).
-This option should, in general, be used on input only when
+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
@@ -962,32 +920,14 @@
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.
-.PP
-The precedence of the applying of single tokens resp. which sequence will be
-used by calculating of the time is complex, e. g. heavily dependent on the
-precision of type of the token.
-.sp
-In example below the second date-string contains "next January", therefore
-it results in next year but in January. And third date-string besides "January"
-contains also additionally "Fri", so it results in the nearest Friday.
-Thus both win before "385 days" resp. make it more precise, because of higher
-precision of this token types.
-.CS
-% clock format [clock scan "5 years 18 months 385 days" -base 0 -gmt 1] -gmt 1
-Thu Jul 21 00:00:00 GMT 1977
-% clock format [clock scan "5 years 18 months 385 days next January" -base 0 -gmt 1] -gmt 1
-Sat Jan 21 00:00:00 GMT 1978
-% clock format [clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1] -gmt 1
-Fri Jan 27 00:00:00 GMT 1978
-.CE
.SH "SEE ALSO"
msgcat(n)
.SH KEYWORDS
clock, date, time
.SH "COPYRIGHT"
Copyright \(co 2004 Kevin B. Kenny . All rights reserved.
'\" Local Variables:
'\" mode: nroff
'\" End:
Index: doc/close.n
==================================================================
--- doc/close.n
+++ doc/close.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/concat.n
==================================================================
--- doc/concat.n
+++ doc/concat.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/configurable.n
==================================================================
--- doc/configurable.n
+++ doc/configurable.n
@@ -1,10 +1,16 @@
'\"
'\" 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.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/continue.n
==================================================================
--- doc/continue.n
+++ doc/continue.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/cookiejar.n
==================================================================
--- doc/cookiejar.n
+++ doc/cookiejar.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/copy.n
==================================================================
--- doc/copy.n
+++ doc/copy.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/coroutine.n
==================================================================
--- doc/coroutine.n
+++ doc/coroutine.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/dde.n
==================================================================
--- doc/dde.n
+++ doc/dde.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/define.n
==================================================================
--- doc/define.n
+++ doc/define.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/dict.n
==================================================================
--- doc/dict.n
+++ doc/dict.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/encoding.n
==================================================================
--- doc/encoding.n
+++ doc/encoding.n
@@ -3,10 +3,16 @@
'\" 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
@@ -14,11 +20,11 @@
\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, Shift\-JIS, utf-8, utf-16, etc. Not every
+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,
Index: doc/eof.n
==================================================================
--- doc/eof.n
+++ doc/eof.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/error.n
==================================================================
--- doc/error.n
+++ doc/error.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/eval.n
==================================================================
--- doc/eval.n
+++ doc/eval.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/exec.n
==================================================================
--- doc/exec.n
+++ doc/exec.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/exit.n
==================================================================
--- doc/exit.n
+++ doc/exit.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/expr.n
==================================================================
--- doc/expr.n
+++ doc/expr.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\" Copyright (c) 2005 Kevin B. Kenny . All rights reserved
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/fblocked.n
==================================================================
--- doc/fblocked.n
+++ doc/fblocked.n
@@ -1,10 +1,16 @@
'\"
'\" 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
Index: doc/fconfigure.n
==================================================================
--- doc/fconfigure.n
+++ doc/fconfigure.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/fcopy.n
==================================================================
--- doc/fcopy.n
+++ doc/fcopy.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/file.n
==================================================================
--- doc/file.n
+++ doc/file.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/fileevent.n
==================================================================
--- doc/fileevent.n
+++ doc/fileevent.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/filename.n
==================================================================
--- doc/filename.n
+++ doc/filename.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/flush.n
==================================================================
--- doc/flush.n
+++ doc/flush.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/for.n
==================================================================
--- doc/for.n
+++ doc/for.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/foreach.n
==================================================================
--- doc/foreach.n
+++ doc/foreach.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/format.n
==================================================================
--- doc/format.n
+++ doc/format.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/fpclassify.n
==================================================================
--- doc/fpclassify.n
+++ doc/fpclassify.n
@@ -2,10 +2,16 @@
'\" Copyright (c) 2018 Kevin B. Kenny . 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!
Index: doc/gets.n
==================================================================
--- doc/gets.n
+++ doc/gets.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/glob.n
==================================================================
--- doc/glob.n
+++ doc/glob.n
@@ -2,10 +2,16 @@
'\" 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
Index: doc/global.n
==================================================================
--- doc/global.n
+++ doc/global.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/history.n
==================================================================
--- doc/history.n
+++ doc/history.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/http.n
==================================================================
--- doc/http.n
+++ doc/http.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/idna.n
==================================================================
--- doc/idna.n
+++ doc/idna.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/if.n
==================================================================
--- doc/if.n
+++ doc/if.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/incr.n
==================================================================
--- doc/incr.n
+++ doc/incr.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/info.n
==================================================================
--- doc/info.n
+++ doc/info.n
@@ -5,10 +5,16 @@
'\" 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!
Index: doc/interp.n
==================================================================
--- doc/interp.n
+++ doc/interp.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/join.n
==================================================================
--- doc/join.n
+++ doc/join.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/lappend.n
==================================================================
--- doc/lappend.n
+++ doc/lappend.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH lappend n "" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/lassign.n
==================================================================
--- doc/lassign.n
+++ doc/lassign.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/ledit.n
==================================================================
--- doc/ledit.n
+++ doc/ledit.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 2022 Ashok P. Nadkarni . All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/library.n
==================================================================
--- doc/library.n
+++ doc/library.n
@@ -2,10 +2,16 @@
'\" 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
Index: doc/lindex.n
==================================================================
--- doc/lindex.n
+++ doc/lindex.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH lindex n 8.4 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/link.n
==================================================================
--- doc/link.n
+++ doc/link.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/linsert.n
==================================================================
--- doc/linsert.n
+++ doc/linsert.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH linsert n 8.2 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/list.n
==================================================================
--- doc/list.n
+++ doc/list.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH list n "" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/llength.n
==================================================================
--- doc/llength.n
+++ doc/llength.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH llength n "" Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/lmap.n
==================================================================
--- doc/lmap.n
+++ doc/lmap.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/load.n
==================================================================
--- doc/load.n
+++ doc/load.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lpop.n
==================================================================
--- doc/lpop.n
+++ doc/lpop.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lrange.n
==================================================================
--- doc/lrange.n
+++ doc/lrange.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH lrange n 7.4 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/lremove.n
==================================================================
--- doc/lremove.n
+++ doc/lremove.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lrepeat.n
==================================================================
--- doc/lrepeat.n
+++ doc/lrepeat.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lreplace.n
==================================================================
--- doc/lreplace.n
+++ doc/lreplace.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 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.
'\"
.TH lreplace n 7.4 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/lreverse.n
==================================================================
--- doc/lreverse.n
+++ doc/lreverse.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lsearch.n
==================================================================
--- doc/lsearch.n
+++ doc/lsearch.n
@@ -4,10 +4,16 @@
'\" Copyright (c) 2001 Kevin B. Kenny . 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!
Index: doc/lseq.n
==================================================================
--- doc/lseq.n
+++ doc/lseq.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/lset.n
==================================================================
--- doc/lset.n
+++ doc/lset.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 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.
'\"
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/lsort.n
==================================================================
--- doc/lsort.n
+++ doc/lsort.n
@@ -4,10 +4,16 @@
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 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.
'\"
.TH lsort n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/mathfunc.n
==================================================================
--- doc/mathfunc.n
+++ doc/mathfunc.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\" Copyright (c) 2005 Kevin B. Kenny . All rights reserved
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/msgcat.n
==================================================================
--- doc/msgcat.n
+++ doc/msgcat.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/my.n
==================================================================
--- doc/my.n
+++ doc/my.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/namespace.n
==================================================================
--- doc/namespace.n
+++ doc/namespace.n
@@ -4,10 +4,16 @@
'\" 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!
Index: doc/next.n
==================================================================
--- doc/next.n
+++ doc/next.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/object.n
==================================================================
--- doc/object.n
+++ doc/object.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/open.n
==================================================================
--- doc/open.n
+++ doc/open.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/package.n
==================================================================
--- doc/package.n
+++ doc/package.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/pid.n
==================================================================
--- doc/pid.n
+++ doc/pid.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/pkgMkIndex.n
==================================================================
--- doc/pkgMkIndex.n
+++ doc/pkgMkIndex.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/platform.n
==================================================================
--- doc/platform.n
+++ doc/platform.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/platform_shell.n
==================================================================
--- doc/platform_shell.n
+++ doc/platform_shell.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/prefix.n
==================================================================
--- doc/prefix.n
+++ doc/prefix.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 2008 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.
'\"
.TH prefix n 8.6 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/proc.n
==================================================================
--- doc/proc.n
+++ doc/proc.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/process.n
==================================================================
--- doc/process.n
+++ doc/process.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/puts.n
==================================================================
--- doc/puts.n
+++ doc/puts.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/pwd.n
==================================================================
--- doc/pwd.n
+++ doc/pwd.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/re_syntax.n
==================================================================
--- doc/re_syntax.n
+++ doc/re_syntax.n
@@ -2,10 +2,16 @@
'\" 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
.ie '\w'o''\w'\C'^o''' .ds qo \C'^o'
.el .ds qo u
.TH re_syntax n "8.1" Tcl "Tcl Built-In Commands"
Index: doc/read.n
==================================================================
--- doc/read.n
+++ doc/read.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/refchan.n
==================================================================
--- doc/refchan.n
+++ doc/refchan.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 2006 Andreas Kupries
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/regexp.n
==================================================================
--- doc/regexp.n
+++ doc/regexp.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/registry.n
==================================================================
--- doc/registry.n
+++ doc/registry.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/regsub.n
==================================================================
--- doc/regsub.n
+++ doc/regsub.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/rename.n
==================================================================
--- doc/rename.n
+++ doc/rename.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/return.n
==================================================================
--- doc/return.n
+++ doc/return.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/safe.n
==================================================================
--- doc/safe.n
+++ doc/safe.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/scan.n
==================================================================
--- doc/scan.n
+++ doc/scan.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/seek.n
==================================================================
--- doc/seek.n
+++ doc/seek.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/self.n
==================================================================
--- doc/self.n
+++ doc/self.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/set.n
==================================================================
--- doc/set.n
+++ doc/set.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/singleton.n
==================================================================
--- doc/singleton.n
+++ doc/singleton.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/socket.n
==================================================================
--- doc/socket.n
+++ doc/socket.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/source.n
==================================================================
--- doc/source.n
+++ doc/source.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/split.n
==================================================================
--- doc/split.n
+++ doc/split.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/subst.n
==================================================================
--- doc/subst.n
+++ doc/subst.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/switch.n
==================================================================
--- doc/switch.n
+++ doc/switch.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/tailcall.n
==================================================================
--- doc/tailcall.n
+++ doc/tailcall.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/tcltest.n
==================================================================
--- doc/tcltest.n
+++ doc/tcltest.n
@@ -5,10 +5,16 @@
'\" 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!
Index: doc/tclvars.n
==================================================================
--- doc/tclvars.n
+++ doc/tclvars.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/tell.n
==================================================================
--- doc/tell.n
+++ doc/tell.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/throw.n
==================================================================
--- doc/throw.n
+++ doc/throw.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/time.n
==================================================================
--- doc/time.n
+++ doc/time.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/timerate.n
==================================================================
--- doc/timerate.n
+++ doc/timerate.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/tm.n
==================================================================
--- doc/tm.n
+++ doc/tm.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 2004-2010 Andreas Kupries
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/trace.n
==================================================================
--- doc/trace.n
+++ doc/trace.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/transchan.n
==================================================================
--- doc/transchan.n
+++ doc/transchan.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/try.n
==================================================================
--- doc/try.n
+++ doc/try.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/unknown.n
==================================================================
--- doc/unknown.n
+++ doc/unknown.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/unload.n
==================================================================
--- doc/unload.n
+++ doc/unload.n
@@ -1,10 +1,16 @@
'\"
'\" Copyright (c) 2003 George 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.
'\"
.TH unload n 8.5 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
Index: doc/unset.n
==================================================================
--- doc/unset.n
+++ doc/unset.n
@@ -3,10 +3,16 @@
'\" 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!
Index: doc/update.n
==================================================================
--- doc/update.n
+++ doc/update.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/uplevel.n
==================================================================
--- doc/uplevel.n
+++ doc/uplevel.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/upvar.n
==================================================================
--- doc/upvar.n
+++ doc/upvar.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/variable.n
==================================================================
--- doc/variable.n
+++ doc/variable.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/vwait.n
==================================================================
--- doc/vwait.n
+++ doc/vwait.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: doc/while.n
==================================================================
--- doc/while.n
+++ doc/while.n
@@ -2,10 +2,16 @@
'\" 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!
Index: doc/zipfs.n
==================================================================
--- doc/zipfs.n
+++ doc/zipfs.n
@@ -3,10 +3,16 @@
'\" Copyright (c) 2015 Christian Werner
'\" Copyright (c) 2015 Sean Woods
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" You may distribute and/or modify this program under the terms of the GNU
+'\" Affero General Public License as published by the Free Software 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!
Index: doc/zlib.n
==================================================================
--- doc/zlib.n
+++ doc/zlib.n
@@ -1,10 +1,16 @@
'\"
'\" 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!
Index: generic/regc_color.c
==================================================================
--- generic/regc_color.c
+++ generic/regc_color.c
@@ -1,9 +1,6 @@
/*
- * colorings of characters
- * This file is #included by regcomp.c.
- *
* 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
@@ -30,10 +27,25 @@
*
* 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
Index: generic/regc_cvec.c
==================================================================
--- generic/regc_cvec.c
+++ generic/regc_cvec.c
@@ -1,9 +1,6 @@
/*
- * Utility functions for handling cvecs
- * This file is #included by regcomp.c.
- *
* 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
@@ -26,10 +23,25 @@
* 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.
*/
Index: generic/regc_lex.c
==================================================================
--- generic/regc_lex.c
+++ generic/regc_lex.c
@@ -1,9 +1,6 @@
/*
- * lexical analyzer
- * This file is #included by regcomp.c.
- *
* 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
@@ -26,10 +23,25 @@
* 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))
Index: generic/regc_locale.c
==================================================================
--- generic/regc_locale.c
+++ generic/regc_locale.c
@@ -7,10 +7,19 @@
* 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;
Index: generic/regc_nfa.c
==================================================================
--- generic/regc_nfa.c
+++ generic/regc_nfa.c
@@ -29,10 +29,19 @@
* 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)
Index: generic/regcomp.c
==================================================================
--- generic/regcomp.c
+++ generic/regcomp.c
@@ -27,10 +27,19 @@
* 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
Index: generic/regcustom.h
==================================================================
--- generic/regcustom.h
+++ generic/regcustom.h
@@ -23,10 +23,19 @@
* 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.
*/
Index: generic/rege_dfa.c
==================================================================
--- generic/rege_dfa.c
+++ generic/rege_dfa.c
@@ -27,10 +27,19 @@
* 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 *);
*/
Index: generic/regerror.c
==================================================================
--- generic/regerror.c
+++ generic/regerror.c
@@ -26,10 +26,19 @@
* 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.
Index: generic/regex.h
==================================================================
--- generic/regex.h
+++ generic/regex.h
@@ -2,12 +2,10 @@
#define _REGEX_H_ /* never again */
#include "tclInt.h"
/*
- * regular expressions
- *
* 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
@@ -29,10 +27,22 @@
* 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.
Index: generic/regexec.c
==================================================================
--- generic/regexec.c
+++ generic/regexec.c
@@ -25,10 +25,19 @@
* 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.
Index: generic/regfree.c
==================================================================
--- generic/regfree.c
+++ generic/regfree.c
@@ -1,8 +1,6 @@
/*
- * regfree - free an RE
- *
* 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
@@ -31,10 +29,24 @@
* 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)
Index: generic/regfronts.c
==================================================================
--- generic/regfronts.c
+++ generic/regfronts.c
@@ -1,11 +1,6 @@
/*
- * regcomp and regexec - front ends to re_ routines
- *
- * Mostly for implementation of backward-compatibility kludges. Note that
- * these routines exist ONLY in char versions.
- *
* 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
@@ -28,10 +23,27 @@
* 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
Index: generic/regguts.h
==================================================================
--- generic/regguts.h
+++ generic/regguts.h
@@ -1,8 +1,6 @@
/*
- * Internal interface definitions, etc., for the reg package
- *
* 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
@@ -25,10 +23,24 @@
* 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.
Index: generic/tcl.decls
==================================================================
--- generic/tcl.decls
+++ generic/tcl.decls
@@ -10,10 +10,17 @@
# Copyright © 2007 Daniel A. Steffen
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
@@ -21,13 +28,13 @@
interface tcl
hooks {tclPlat tclInt tclIntPlat}
scspec EXTERN
-# Declare each of the functions in the public Tcl interface. Note that
-# the an index should never be reused for a different function in order
-# to preserve backwards compatibility.
+# 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)
}
@@ -102,10 +109,14 @@
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 {
@@ -114,10 +125,14 @@
}
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,
@@ -145,10 +160,15 @@
}
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)
@@ -157,13 +177,13 @@
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 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,
@@ -171,41 +191,59 @@
}
declare 44 {
int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
-declare 45 {
- int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
- void *objcPtr, Tcl_Obj ***objvPtr)
-}
+#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)
}
-declare 47 {
- int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
- void *lengthPtr)
-}
+#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,
@@ -212,19 +250,36 @@
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)
@@ -246,10 +301,18 @@
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 {
@@ -311,10 +374,16 @@
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)
@@ -420,13 +489,21 @@
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)
@@ -461,17 +538,22 @@
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)
}
@@ -558,14 +640,31 @@
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 {
@@ -602,10 +701,14 @@
# }
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)
@@ -700,10 +803,14 @@
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)
@@ -730,13 +837,22 @@
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)
@@ -745,10 +861,15 @@
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 {
@@ -766,10 +887,28 @@
}
# 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 {
@@ -783,29 +922,48 @@
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)
}
@@ -820,25 +978,61 @@
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)
@@ -893,10 +1087,14 @@
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 {
@@ -973,10 +1171,18 @@
}
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,
@@ -1054,10 +1260,18 @@
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)
@@ -1084,10 +1298,15 @@
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 {
@@ -1096,10 +1315,15 @@
}
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,
@@ -1180,10 +1404,14 @@
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,
@@ -1242,10 +1470,15 @@
}
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 {
@@ -1254,10 +1487,15 @@
}
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 {
@@ -1301,10 +1539,29 @@
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 {
@@ -1347,10 +1604,22 @@
# 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)
}
@@ -1660,10 +1929,15 @@
# 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,
@@ -2226,10 +2500,15 @@
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,
@@ -2372,10 +2651,170 @@
# ----- 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.
@@ -2390,11 +2829,11 @@
# Mac OS X specific functions
declare 1 {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
- int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath)
+ Tcl_Size hasResourceFile, Tcl_Size maxPathLen, char *libraryPath)
}
declare 2 {
void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
Index: generic/tcl.h
==================================================================
--- generic/tcl.h
+++ generic/tcl.h
@@ -1,20 +1,35 @@
/*
- * tcl.h --
- *
- * This header file describes the externally-visible facilities of the
- * Tcl interpreter.
- *
* 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
/*
@@ -103,10 +118,16 @@
* prior Tcl releases.
*/
#include
#include
+
+/* Needed for PTRDIFF_MAX */
+#include
+
+
+#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
@@ -207,14 +228,10 @@
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# endif
#endif
-#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED)
-# define CONST86 const
-#endif
-
/*
* Make sure EXTERN isn't defined elsewhere.
*/
#ifdef EXTERN
@@ -320,28 +337,16 @@
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
-#if TCL_MAJOR_VERSION < 9
- typedef int Tcl_Size;
-# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1))
-# define TCL_SIZE_MODIFIER ""
-#else
- typedef ptrdiff_t Tcl_Size;
-# define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1))
-# define TCL_SIZE_MODIFIER TCL_T_MODIFIER
-#endif /* TCL_MAJOR_VERSION */
+typedef ptrdiff_t Tcl_Size;
+#define TCL_SIZE_MAX PTRDIFF_MAX
+#define TCL_SIZE_MODIFIER TCL_T_MODIFIER
#ifdef _WIN32
-# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T)
- typedef struct __stat64 Tcl_StatBuf;
-# elif defined(_USE_32BIT_TIME_T)
- typedef struct _stati64 Tcl_StatBuf;
-# else
- typedef struct _stat32i64 Tcl_StatBuf;
-# endif
+typedef struct __stat64 Tcl_StatBuf;
#elif defined(__CYGWIN__)
typedef struct {
unsigned st_dev;
unsigned short st_ino;
unsigned short st_mode;
@@ -462,32 +467,22 @@
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
-#if TCL_MAJOR_VERSION > 8
Tcl_Size start; /* Character offset of first character in
* match. */
Tcl_Size end; /* Character offset of first character after
* the match. */
-#else
- long start;
- long end;
-#endif
} 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. */
-#if TCL_MAJOR_VERSION > 8
Tcl_Size extendStart; /* The offset at which a subsequent match
* might begin. */
-#else
- long extendStart;
- long reserved; /* Reserved for later use. */
-#endif
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the struct's
* reference in tclDecls.h.
@@ -578,26 +573,19 @@
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);
-#if TCL_MAJOR_VERSION > 8
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_FileFreeProc Tcl_FreeProc
#define Tcl_EncodingFreeProc Tcl_FreeProc
-#else
-#define Tcl_ObjCmdProc2 Tcl_ObjCmdProc
-#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc
-typedef void (Tcl_FreeProc) (char *blockPtr);
-#endif
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);
@@ -615,41 +603,21 @@
typedef void (Tcl_ServiceModeHookProc) (int mode);
typedef void *(Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
-/* Abstract List functions */
-typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr);
-typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
- Tcl_Size index, struct Tcl_Obj** elemObj);
-typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
- Tcl_Size fromIdx, Tcl_Size toIdx, struct Tcl_Obj **newObjPtr);
-typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp,
- struct Tcl_Obj *listPtr, struct Tcl_Obj **newObjPtr);
-typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp,
- struct Tcl_Obj *listPtr, Tcl_Size *objcptr, struct Tcl_Obj ***objvptr);
-typedef struct Tcl_Obj *(Tcl_ObjTypeSetElement) (Tcl_Interp *interp,
- struct Tcl_Obj *listPtr, Tcl_Size indexCount,
- struct Tcl_Obj *const indexArray[], struct Tcl_Obj *valueObj);
-typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp,
- struct Tcl_Obj *listObj, Tcl_Size first, Tcl_Size numToDelete,
- Tcl_Size numToInsert, struct Tcl_Obj *const insertObjs[]);
-typedef int (Tcl_ObjTypeInOperatorProc) (Tcl_Interp *interp,
- struct Tcl_Obj *valueObj, struct Tcl_Obj *listObj, int *boolResult);
-
-#ifndef TCL_NO_DEPRECATED
-# define Tcl_PackageInitProc Tcl_LibraryInitProc
-# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
-#endif
-
/*
*----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
* 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
@@ -662,47 +630,13 @@
* 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. */
-#if TCL_MAJOR_VERSION > 8
size_t version;
-
- /* List emulation functions - ObjType Version 1 */
- Tcl_ObjTypeLengthProc *lengthProc;
- /* Return the [llength] of the AbstractList */
- Tcl_ObjTypeIndexProc *indexProc;
- /* Return a value (Tcl_Obj) at a given index */
- Tcl_ObjTypeSliceProc *sliceProc;
- /* Return an AbstractList for
- * [lrange $al $start $end] */
- Tcl_ObjTypeReverseProc *reverseProc;
- /* Return an AbstractList for [lreverse $al] */
- Tcl_ObjTypeGetElements *getElementsProc;
- /* Return an objv[] of all elements in the list */
- Tcl_ObjTypeSetElement *setElementProc;
- /* Replace the element at the indicies with the
- * given valueObj. */
- Tcl_ObjTypeReplaceProc *replaceProc;
- /* Replace sublist with another sublist */
- Tcl_ObjTypeInOperatorProc *inOperProc;
- /* "in" and "ni" expr list operation.
- * Determine if the given string value matches
- * an element in the list. */
-#endif
} Tcl_ObjType;
-#if TCL_MAJOR_VERSION > 8
-# define TCL_OBJTYPE_V0 0, \
- 0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */
-# define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \
- a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */
-# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \
- a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */
-#else
-# define TCL_OBJTYPE_V0 /* just empty */
-#endif
/*
* 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
@@ -729,11 +663,11 @@
* 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.
*/
-typedef struct Tcl_Obj {
+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
@@ -750,11 +684,11 @@
* 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: */
-} Tcl_Obj;
+};
/*
*----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
* five fields must match exactly the fields in a Namespace structure (see
@@ -940,15 +874,11 @@
/*
* Flags that may be passed to Tcl_UniCharToUtf.
* TCL_COMBINE Combine surrogates
*/
-#if TCL_MAJOR_VERSION > 8
-# define TCL_COMBINE 0x1000000
-#else
-# define TCL_COMBINE 0
-#endif
+#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!
@@ -1049,15 +979,11 @@
*----------------------------------------------------------------------------
* Forward declarations of Tcl_HashTable and related types.
*/
#ifndef TCL_HASH_TYPE
-#if TCL_MAJOR_VERSION > 8
-# define TCL_HASH_TYPE size_t
-#else
-# define TCL_HASH_TYPE unsigned
-#endif
+#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;
@@ -1178,19 +1104,14 @@
* **bucketPtr. */
Tcl_Size numEntries; /* Total number of entries present in
* table. */
Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
-#if TCL_MAJOR_VERSION > 8
size_t mask; /* Mask value used in hashing function. */
-#endif
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
-#if TCL_MAJOR_VERSION < 9
- int mask; /* Mask value used in hashing function. */
-#endif
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
@@ -1304,17 +1225,13 @@
* 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 {
-#if TCL_MAJOR_VERSION > 8
long long sec; /* Seconds. */
-#else
- long sec; /* Seconds. */
-#endif
-#if defined(_CYGWIN_) && TCL_MAJOR_VERSION > 8
- int usec; /* Microseconds. */
+#if defined(_WIN32) && defined(_WIN64)
+ int usec; /* Microseconds. */
#else
long usec; /* Microseconds. */
#endif
} Tcl_Time;
@@ -1360,15 +1277,11 @@
/*
* Value to use as the closeProc for a channel that supports the close2Proc
* interface.
*/
-#if TCL_MAJOR_VERSION > 8
-# define TCL_CLOSE2PROC NULL
-#else
-# define TCL_CLOSE2PROC ((void *) 1)
-#endif
+#define TCL_CLOSE2PROC NULL
/*
* Channel version tag. This was introduced in 8.3.2/8.4.
*/
@@ -1912,16 +1825,14 @@
Tcl_Size numTokens; /* Total number of tokens in command. */
Tcl_Size tokensAvailable; /* Total number of tokens available at
* *tokenPtr. */
int errorType; /* One of the parsing error types defined
* above. */
-#if TCL_MAJOR_VERSION > 8
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
* This information is used by
* Tcl_CommandComplete. */
-#endif
/*
* The fields below are intended only for the private use of the parser.
* They should not be used by functions that invoke Tcl_ParseCommand.
*/
@@ -1936,13 +1847,10 @@
* 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). */
-#if TCL_MAJOR_VERSION < 9
- int incomplete;
-#endif
Tcl_Token staticTokens[NUM_STATIC_TOKENS];
/* Initial space for tokens for command. This
* space should be large enough to accommodate
* most commands; dynamic space is allocated
* for very large commands that don't fit
@@ -1995,11 +1903,11 @@
* 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 - Not used any more.
+ * 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
@@ -2020,25 +1928,21 @@
* when adding bits.
*/
#define TCL_ENCODING_START 0x01
#define TCL_ENCODING_END 0x02
-#if TCL_MAJOR_VERSION > 8
-# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */
-#else
-# define TCL_ENCODING_STOPONERROR 0x04
-#endif
+#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 TCL_ENCODING_STOPONERROR
+#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
@@ -2077,34 +1981,24 @@
* 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
-# if TCL_MAJOR_VERSION > 8
# define TCL_UTF_MAX 4
-# else
-# define TCL_UTF_MAX 3
-# endif
#endif
/*
* This represents a Unicode character. Any changes to this should also be
* reflected in regcustom.h.
*/
-#if TCL_UTF_MAX == 4
- /*
- * 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.
- */
+/*
+ * 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;
-#elif TCL_UTF_MAX == 3 && !defined(BUILD_tcl)
-typedef unsigned short Tcl_UniChar;
-#else
-# error "This TCL_UTF_MAX value is not supported"
-#endif
/*
*----------------------------------------------------------------------------
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
* provide the system with the embedded configuration data.
@@ -2130,15 +2024,11 @@
* 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);
-#if TCL_MAJOR_VERSION > 8
#define Tcl_LimitHandlerDeleteProc Tcl_FreeProc
-#else
-typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData);
-#endif
#if 0
/*
*----------------------------------------------------------------------------
* We would like to provide an anonymous structure "mp_int" here, which is
@@ -2276,10 +2166,11 @@
*/
#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.
*/
@@ -2291,15 +2182,11 @@
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
*/
-#if TCL_MAJOR_VERSION > 8
-# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *))
-#else
-# define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
-#endif
+#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
@@ -2317,23 +2204,11 @@
#else
# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
#endif
#ifdef USE_TCL_STUBS
-#if TCL_MAJOR_VERSION < 9
-# if TCL_UTF_MAX < 4
-# define Tcl_InitStubs(interp, version, exact) \
- (Tcl_InitStubs)(interp, version, \
- (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
- TCL_STUB_MAGIC)
-# else
-# define Tcl_InitStubs(interp, version, exact) \
- (Tcl_InitStubs)(interp, "8.7.0", \
- (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \
- TCL_STUB_MAGIC)
-# endif
-#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+#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
@@ -2341,13 +2216,11 @@
(Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0b2"), \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
TCL_STUB_MAGIC)
#endif
#else
-#if TCL_MAJOR_VERSION < 9
-# error "Please define -DUSE_TCL_STUBS"
-#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
+#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) \
@@ -2376,13 +2249,10 @@
Tcl_PanicProc *panicProc);
EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp,
const char *prefix,
Tcl_LibraryInitProc *initProc,
Tcl_LibraryInitProc *safeInitProc);
-#ifndef TCL_NO_DEPRECATED
-# define Tcl_StaticPackage Tcl_StaticLibrary
-#endif
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);
@@ -2393,11 +2263,11 @@
#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) && (TCL_MAJOR_VERSION > 8)
+#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) \
@@ -2421,10 +2291,187 @@
(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.
*/
@@ -2613,18 +2660,21 @@
#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:
Index: generic/tclAlloc.c
==================================================================
--- generic/tclAlloc.c
+++ generic/tclAlloc.c
@@ -1,22 +1,34 @@
/*
- * 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.
- *
* 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.
*/
Index: generic/tclArithSeries.c
==================================================================
--- generic/tclArithSeries.c
+++ generic/tclArithSeries.c
@@ -8,10 +8,22 @@
*
* 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
#include
/*
@@ -68,52 +80,55 @@
unsigned precision; /* Number of decimal places to render. */
} ArithSeriesDbl;
/* Forward declarations. */
-static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *),
- Tcl_Obj *arithSeriesObj, Tcl_Size index,
- Tcl_Obj **elemObj);
-static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
-static int TclArithSeriesObjRange(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesObj, Tcl_Size fromIdx,
- Tcl_Size toIdx, Tcl_Obj **newObjPtr);
-static int TclArithSeriesObjReverse(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr);
-static int TclArithSeriesGetElements(Tcl_Interp *interp,
- Tcl_Obj *objPtr, Tcl_Size *objcPtr,
- Tcl_Obj ***objvPtr);
+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);
-static int ArithSeriesInOperation(Tcl_Interp *interp,
- Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj,
- int *boolResult);
-static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj,
- Tcl_Obj **stepObj);
/* ------------------------ ArithSeries object type -------------------------- */
-static const Tcl_ObjType arithSeriesType = {
- "arithseries", /* name */
+
+static int ArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj);
+
+
+static ObjectType arithSeriesType = {
+ "arithseries",
FreeArithSeriesInternalRep, /* freeIntRepProc */
DupArithSeriesInternalRep, /* dupIntRepProc */
UpdateStringOfArithSeries, /* updateStringProc */
SetArithSeriesFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V2(
- ArithSeriesObjLength,
- TclArithSeriesObjIndex,
- TclArithSeriesObjRange,
- TclArithSeriesObjReverse,
- TclArithSeriesGetElements,
- NULL, // SetElement
- NULL, // Replace
- ArithSeriesInOperation) // "in" operator
+ 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.
@@ -122,11 +137,11 @@
* - ArithSeriesIndexDbl -- base list indexing operation for doubles
* - ArithSeriesIndexInt -- " " " " " integers
* - ArithSeriesGetInternalRep -- Return the internal rep from a Tcl_Obj
* - Precision -- determine the number of factional digits for the given
* double value
- * - maxPrecision -- Using the values provide, determine the longest percision
+ * - maxPrecision -- Using the values provided, determine the longest precision
* in the arithSeries
*/
static inline double
power10(
@@ -223,11 +238,11 @@
dp = i>dp ? i : dp;
i = Precision(end);
dp = i>dp ? i : dp;
return dp;
}
-
+
/*
*----------------------------------------------------------------------
*
* ArithSeriesLen --
*
@@ -284,101 +299,10 @@
}
/*
*----------------------------------------------------------------------
*
- * 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 = &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; ielements[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);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* NewArithSeriesInt --
*
* Creates a new ArithSeries object. The returned object has
* refcount = 0.
*
@@ -421,11 +345,11 @@
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
- arithSeriesObj->typePtr = &arithSeriesType;
+ arithSeriesObj->typePtr = (Tcl_ObjType *)&arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
@@ -480,11 +404,11 @@
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->precision = maxPrecision(start, end, step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
- arithSeriesObj->typePtr = &arithSeriesType;
+ arithSeriesObj->typePtr = (Tcl_ObjType *)&arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
@@ -557,14 +481,13 @@
*
* None.
*----------------------------------------------------------------------
*/
-int
+Tcl_Obj *
TclNewArithSeriesObj(
Tcl_Interp *interp, /* For error reporting */
- Tcl_Obj **arithSeriesObj, /* return value */
int useDoubles, /* Flag indicates values start,
** end, step, are treated as doubles */
Tcl_Obj *startObj, /* Starting value */
Tcl_Obj *endObj, /* Ending limit */
Tcl_Obj *stepObj, /* increment value */
@@ -571,10 +494,11 @@
Tcl_Obj *lenObj) /* Number of elements */
{
double dstart, dend, dstep;
Tcl_WideInt start, end, step;
Tcl_WideInt len = -1;
+ Tcl_Obj *arithSeriesObjPtr = NULL;
if (startObj) {
assignNumber(useDoubles, &start, &dstart, startObj);
} else {
start = 0;
@@ -586,20 +510,20 @@
step = dstep;
} else {
dstep = step;
}
if (dstep == 0) {
- TclNewObj(*arithSeriesObj);
- return TCL_OK;
+ TclNewObj(arithSeriesObjPtr);
+ return arithSeriesObjPtr;
}
}
if (endObj) {
assignNumber(useDoubles, &end, &dend, endObj);
}
if (lenObj) {
if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) {
- return TCL_ERROR;
+ return arithSeriesObjPtr;
}
}
if (startObj && endObj) {
if (!stepObj) {
@@ -626,13 +550,13 @@
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;
+ // Make computed end value match argument(s) precision
+ dend = ArithRound(dend, precision);
+ end = dend;
} else {
end = start + (step * (len - 1));
dend = end;
}
}
@@ -639,45 +563,41 @@
if (len > TCL_SIZE_MAX) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"max length of a Tcl list exceeded", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL);
- return TCL_ERROR;
+ return arithSeriesObjPtr;
}
- if (arithSeriesObj) {
- *arithSeriesObj = (useDoubles)
- ? NewArithSeriesDbl(dstart, dend, dstep, len)
- : NewArithSeriesInt(start, end, step, len);
- }
- return TCL_OK;
+ arithSeriesObjPtr = useDoubles
+ ? NewArithSeriesDbl(dstart, dend, dstep, len)
+ : NewArithSeriesInt(start, end, step, len);
+ return arithSeriesObjPtr;
}
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesObjIndex --
+ * ArithSeriesObjIndex --
*
- * Returns the element with the specified index in the list
- * represented by the specified Arithmetic Sequence object.
- * If the index is out of range, TCL_ERROR is returned,
- * otherwise TCL_OK is returned and the integer value of the
- * element is stored in *element.
+ * Stores in **resultPtr the element with the specified index in the list
+ * represented by the specified Arithmetic Sequence object.
*
* Results:
*
- * TCL_OK on success.
+ * On success, returns TCL_OK and stores the position of the element in
+ * *element. Returns TCL_ERROR if the index is out of range.
*
* Side Effects:
*
* On success, the integer pointed by *element is modified.
* An empty string ("") is assigned if index is out-of-bounds.
*
*----------------------------------------------------------------------
*/
int
-TclArithSeriesObjIndex(
+ArithSeriesObjIndex(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *arithSeriesObj, /* List obj */
Tcl_Size index, /* index to element of interest */
Tcl_Obj **elemObj) /* Return value */
{
@@ -712,23 +632,117 @@
*
* None.
*
*----------------------------------------------------------------------
*/
-Tcl_Size
-ArithSeriesObjLength(
- Tcl_Obj *arithSeriesObj)
+int ArithSeriesObjLength(TCL_UNUSED(Tcl_Interp *),
+ Tcl_Obj *arithSeriesObj
+ ,Tcl_Size *result)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
- return arithSeriesRepPtr->len;
+ *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; ielements[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);
+ }
}
+
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesObjStep --
+ * ArithSeriesObjStep --
*
* Return a Tcl_Obj with the step value from the give ArithSeries Obj.
* refcount = 0.
*
* Results:
@@ -740,12 +754,12 @@
*
* None.
*----------------------------------------------------------------------
*/
-int
-TclArithSeriesObjStep(
+static int
+ArithSeriesObjStep(
Tcl_Obj *arithSeriesObj,
Tcl_Obj **stepObj)
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
@@ -789,11 +803,11 @@
}
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesObjRange --
+ * ArithSeriesObjRange --
*
* Makes a slice of an ArithSeries value.
* *arithSeriesObj must be known to be a valid list.
*
* Results:
@@ -806,16 +820,16 @@
*
*----------------------------------------------------------------------
*/
int
-TclArithSeriesObjRange(
+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 **newObjPtr) /* return value */
+ Tcl_Obj **resPtrPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
(void)interp; /* silence compiler */
@@ -829,11 +843,11 @@
if (toIdx >= arithSeriesRepPtr->len) {
toIdx = arithSeriesRepPtr->len-1;
}
if (fromIdx > toIdx || fromIdx >= arithSeriesRepPtr->len) {
- TclNewObj(*newObjPtr);
+ TclNewObj(*resPtrPtr);
return TCL_OK;
}
if (fromIdx < 0) {
fromIdx = 0;
@@ -843,25 +857,25 @@
}
if (toIdx > arithSeriesRepPtr->len - 1) {
toIdx = arithSeriesRepPtr->len - 1;
}
- TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
+ ArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
Tcl_IncrRefCount(startObj);
- TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
+ ArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
Tcl_IncrRefCount(endObj);
- TclArithSeriesObjStep(arithSeriesObj, &stepObj);
+ ArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) {
- int status = TclNewArithSeriesObj(NULL, newObjPtr,
+ Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(interp,
arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);
-
+ *resPtrPtr = newSlicePtr;
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
- return status;
+ return newSlicePtr ? TCL_OK : TCL_ERROR;
}
/*
* In-place is possible.
*/
@@ -903,18 +917,18 @@
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
- *newObjPtr = arithSeriesObj;
+ *resPtrPtr = arithSeriesObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesGetElements --
+ * ArithSeriesGetElements --
*
* This function returns an (objc,objv) array of the elements in a list
* object.
*
* Results:
@@ -937,20 +951,20 @@
*
*----------------------------------------------------------------------
*/
int
-TclArithSeriesGetElements(
+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, &arithSeriesType)) {
+ if (TclHasInternalRep(objPtr,(Tcl_ObjType *)&arithSeriesType)) {
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
Tcl_Obj **objv;
Tcl_Size objc = arithSeriesRepPtr->len;
if (objc > 0) {
@@ -971,11 +985,11 @@
}
arithSeriesRepPtr->elements = objv;
Tcl_Size i;
for (i = 0; i < objc; i++) {
- int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
+ int status = ArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
if (status) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objv[i]);
@@ -998,53 +1012,52 @@
}
/*
*----------------------------------------------------------------------
*
- * TclArithSeriesObjReverse --
+ * 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 ogiginal obj will be modified and returned if it is not Shared.
+ * The original obj will be modified and returned if it is not Shared.
*
*----------------------------------------------------------------------
*/
int
-TclArithSeriesObjReverse(
+ArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
- Tcl_Obj *arithSeriesObj, /* List object to reverse. */
- Tcl_Obj **newObjPtr)
+ Tcl_Obj *arithSeriesObj /* List object to reverse. */
+ )
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
- Tcl_Obj *resultObj;
Tcl_WideInt start, end, step, len;
double dstart, dend, dstep;
int isDouble;
(void)interp;
- if (newObjPtr == NULL) {
- return TCL_ERROR;
+ if (Tcl_IsShared(arithSeriesObj)) {
+ Tcl_Panic("%s called with shared object", "ArithSeriesObjReverse");
}
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
isDouble = arithSeriesRepPtr->isDouble;
len = arithSeriesRepPtr->len;
- TclArithSeriesObjIndex(NULL, arithSeriesObj, len - 1, &startObj);
+ ArithSeriesObjIndex(NULL, arithSeriesObj, len - 1, &startObj);
Tcl_IncrRefCount(startObj);
- TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj);
+ ArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj);
Tcl_IncrRefCount(endObj);
- TclArithSeriesObjStep(arithSeriesObj, &stepObj);
+ ArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (isDouble) {
Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
Tcl_GetDoubleFromObj(NULL, endObj, &dend);
@@ -1057,50 +1070,33 @@
Tcl_GetWideIntFromObj(NULL, stepObj, &step);
step = -step;
TclSetIntObj(stepObj, step);
}
- if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) {
- Tcl_Obj *lenObj;
-
- TclNewIntObj(lenObj, len);
- if (TclNewArithSeriesObj(NULL, &resultObj, isDouble,
- startObj, endObj, stepObj, lenObj) != TCL_OK) {
- resultObj = NULL;
- }
- Tcl_DecrRefCount(lenObj);
- } else {
- /*
- * In-place is possible.
- */
-
- 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);
- resultObj = arithSeriesObj;
- }
+ 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);
- *newObjPtr = resultObj;
-
return TCL_OK;
}
+
/*
*----------------------------------------------------------------------
*
* UpdateStringOfArithSeries --
@@ -1126,17 +1122,16 @@
* this version takes more care of space than time.
*
*----------------------------------------------------------------------
*/
static void
-UpdateStringOfArithSeries(
- Tcl_Obj *arithSeriesObjPtr)
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries *)
- arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1;
char *p;
- Tcl_Obj *eleObj;
+ Tcl_Obj *elemObj;
Tcl_Size i, bytlen = 0;
/*
* Pass 1: estimate space.
*/
@@ -1164,27 +1159,29 @@
/*
* Pass 2: generate the string repr.
*/
- p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
+ p = Tcl_InitStringRep(arithSeriesPtr, NULL, bytlen);
for (i = 0; i < arithSeriesRepPtr->len; i++) {
- if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) {
+ if (ArithSeriesObjIndex(NULL, arithSeriesPtr, i, &elemObj) == TCL_OK) {
Tcl_Size slen;
- char *str = TclGetStringFromObj(eleObj, &slen);
+ char *str = Tcl_GetStringFromObj(elemObj, &slen);
strcpy(p, str);
p[slen] = ' ';
p += slen + 1;
- Tcl_DecrRefCount(eleObj);
+ Tcl_DecrRefCount(elemObj);
} // else TODO: report error here?
}
if (bytlen > 0) {
- arithSeriesObjPtr->bytes[bytlen - 1] = '\0';
+ arithSeriesPtr->bytes[bytlen - 1] = '\0';
}
- arithSeriesObjPtr->length = bytlen - 1;
+ arithSeriesPtr->length = bytlen - 1;
+ return;
}
+
/*
*----------------------------------------------------------------------
*
* ArithSeriesInOperator --
@@ -1204,38 +1201,38 @@
*/
static int
ArithSeriesInOperation(
Tcl_Interp *interp,
- Tcl_Obj *valueObj,
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;
+ 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) {
+ status = Tcl_GetDoubleFromObj(interp, valueObj, &y);
+ if (status != TCL_OK) {
test = 0;
- } else {
- const char *vstr = TclGetStringFromObj(valueObj, &vlen);
- index = (y - dblRepPtr->start) / dblRepPtr->step;
+ } else {
+ char *vstr = Tcl_GetStringFromObj(valueObj, &vlen);
+ index = (y - dblRepPtr->start) / dblRepPtr->step;
while (incr<2) {
Tcl_Obj *elemObj;
elen = 0;
- TclArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj);
+ ArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj);
- const char *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : "";
+ 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 */
@@ -1242,11 +1239,11 @@
if (test) {
break;
}
incr++;
}
- }
+ }
if (boolResult) {
*boolResult = test;
}
} else {
ArithSeriesInt *intRepPtr = (ArithSeriesInt *) repPtr;
@@ -1260,14 +1257,14 @@
} else {
Tcl_Obj *elemObj;
elen = 0;
index = (y - intRepPtr->start) / intRepPtr->step;
- TclArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj);
+ ArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj);
- char const *vstr = TclGetStringFromObj(valueObj, &vlen);
- char const *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : "";
+ 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);
Index: generic/tclAssembly.c
==================================================================
--- generic/tclAssembly.c
+++ generic/tclAssembly.c
@@ -1,19 +1,31 @@
+/*
+ * 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.
*
- * 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.
- */
+*/
/*-
*- THINGS TO DO:
*- More instructions:
*- done - alternate exit point (affects stack and exception range checking)
@@ -324,11 +336,11 @@
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
DupAssembleCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
@@ -886,11 +898,11 @@
/*
* Set up the compilation environment, and assemble the code.
*/
- source = TclGetStringFromObj(objPtr, &sourceLen);
+ 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.
@@ -1309,11 +1321,11 @@
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
- operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
break;
case ASSEM_1BYTE:
@@ -1476,11 +1488,11 @@
TalInstructionTable+tblIdx);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
- operand1 = TclGetStringFromObj(operand1Obj, &operand1Len);
+ operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0);
/*
* Assumes that PUSH is the first slot!
*/
@@ -2316,11 +2328,11 @@
Tcl_Size localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return TCL_INDEX_NONE;
}
- varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
+ varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
return TCL_INDEX_NONE;
}
localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
Index: generic/tclAsync.c
==================================================================
--- generic/tclAsync.c
+++ generic/tclAsync.c
@@ -1,18 +1,30 @@
/*
- * 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.
- *
* 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;
Index: generic/tclBasic.c
==================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -1,12 +1,6 @@
/*
- * tclBasic.c --
- *
- * Contains the basic facilities for TCL command interpretation,
- * including interpreter creation and deletion, command creation and
- * deletion, and command/script execution.
- *
* 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
@@ -14,10 +8,28 @@
* 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.
+*/
+
+/*
+ * 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"
@@ -219,11 +231,11 @@
static void TEOV_SwitchVarFrame(Tcl_Interp *interp);
static void TEOV_PushExceptionHandlers(Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[], int flags);
static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp,
Tcl_Obj *namePtr, Namespace *lookupNsPtr);
-static int TEOV_NotFound(Tcl_Interp *interp, int objc,
+static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
Tcl_Obj *const objv[]);
static Tcl_NRPostProc RewindCoroutineCallback;
@@ -664,11 +676,11 @@
Tcl_WrongNumArgs(interp, 1, objv, "?option?");
return TCL_ERROR;
}
if (objc == 2) {
Tcl_Size len;
- const char *arg = TclGetStringFromObj(objv[1], &len);
+ const char *arg = Tcl_GetStringFromObj(objv[1], &len);
if (len == 7 && !strcmp(arg, "version")) {
char buf[80];
const char *p = strchr((char *)clientData, '.');
if (p) {
const char *q = strchr(p + 1, '.');
@@ -4185,38 +4197,38 @@
* 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 = TclGetStringFromObj(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);
+ 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
@@ -4293,11 +4305,11 @@
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
- result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
+ 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 {
@@ -4797,11 +4809,11 @@
* error log: get it out of the itemPtr. The details depend on the
* type.
*/
listPtr = Tcl_NewListObj(objc, objv);
- cmdString = TclGetStringFromObj(listPtr, &cmdLen);
+ cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen);
Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
Tcl_DecrRefCount(listPtr);
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
return result;
@@ -4808,11 +4820,11 @@
}
static int
TEOV_NotFound(
Tcl_Interp *interp,
- int objc,
+ Tcl_Size objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
{
Command * cmdPtr;
Interp *iPtr = (Interp *) interp;
@@ -4943,11 +4955,11 @@
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
Tcl_Size length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int traceCode = TCL_OK;
- const char *command = TclGetStringFromObj(commandPtr, &length);
+ 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
@@ -4995,11 +5007,11 @@
int 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 = TclGetStringFromObj(commandPtr, &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);
@@ -6143,11 +6155,15 @@
* TODO: Create a test to demo this need, or eliminate it.
* FIXME OPT: preserve just the internal rep?
*/
Tcl_IncrRefCount(objPtr);
- listPtr = TclListObjCopy(interp, 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
@@ -6255,11 +6271,11 @@
iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr);
Tcl_IncrRefCount(objPtr);
- script = TclGetStringFromObj(objPtr, &numSrcBytes);
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
TclDecrRefCount(objPtr);
iPtr->scriptCLLocPtr = saveCLLocPtr;
@@ -6286,11 +6302,11 @@
const char *script;
Tcl_Size numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
- script = TclGetStringFromObj(objPtr, &numSrcBytes);
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
/*
* We are returning to level 0, so should call TclResetCancellation.
@@ -6817,11 +6833,11 @@
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
Tcl_Size length;
- const char *message = TclGetStringFromObj(objPtr, &length);
+ const char *message = Tcl_GetStringFromObj(objPtr, &length);
Interp *iPtr = (Interp *) interp;
Tcl_IncrRefCount(objPtr);
/*
@@ -7037,11 +7053,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7077,11 +7093,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7223,11 +7239,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -7277,11 +7293,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
@@ -7341,11 +7357,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
d1 = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
@@ -7356,11 +7372,11 @@
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], tclDoubleType);
if (irPtr) {
d2 = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
@@ -7401,11 +7417,11 @@
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
Tcl_Size numBytes;
- const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
+ const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
while (numBytes) {
if (*bytes == '-') {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
@@ -7518,11 +7534,11 @@
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (TclHasInternalRep(objv[1], &tclDoubleType)) {
+ if (TclHasInternalRep(objv[1], tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
#endif
return TCL_ERROR;
Index: generic/tclBinary.c
==================================================================
--- generic/tclBinary.c
+++ generic/tclBinary.c
@@ -1,17 +1,29 @@
/*
- * tclBinary.c --
- *
- * This file contains the implementation of the "binary" Tcl built-in
- * command and the Tcl binary data object.
- *
* 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
@@ -161,11 +173,11 @@
"bytearray",
FreeProperByteArrayInternalRep,
DupProperByteArrayInternalRep,
UpdateStringOfByteArray,
NULL,
- TCL_OBJTYPE_V0
+ 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
@@ -382,39 +394,10 @@
*numBytesPtr = baPtr->used;
}
return baPtr->bytes;
}
-#if !defined(TCL_NO_DEPRECATED)
-unsigned char *
-TclGetBytesFromObj(
- Tcl_Interp *interp, /* For error reporting */
- Tcl_Obj *objPtr, /* Value to extract from */
- void *numBytesPtr) /* If non-NULL, write the number of bytes
- * in the array here */
-{
- Tcl_Size numBytes = 0;
- unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes);
-
- if (bytes && numBytesPtr) {
- if (numBytes > INT_MAX) {
- /* Caller asked for numBytes to be written to an int, but the
- * value is outside the int range. */
-
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "byte sequence length exceeds INT_MAX", -1));
- Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", (void *)NULL);
- }
- return NULL;
- } else {
- *(int *)numBytesPtr = (int) numBytes;
- }
- }
- return bytes;
-}
-#endif
/*
*----------------------------------------------------------------------
*
* Tcl_SetByteArrayLength --
@@ -500,11 +483,11 @@
Tcl_Size limit,
int demandProper,
ByteArray **byteArrayPtrPtr)
{
Tcl_Size length;
- const char *src = TclGetStringFromObj(objPtr, &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;
@@ -1083,11 +1066,11 @@
}
case 'b':
case 'B': {
unsigned char *last;
- str = TclGetStringFromObj(objv[arg], &length);
+ str = Tcl_GetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
@@ -1145,11 +1128,11 @@
case 'h':
case 'H': {
unsigned char *last;
int c;
- str = TclGetStringFromObj(objv[arg], &length);
+ str = Tcl_GetStringFromObj(objv[arg], &length);
arg++;
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
@@ -2000,11 +1983,11 @@
* 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, &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
@@ -2020,11 +2003,11 @@
* 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, &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
@@ -2510,11 +2493,11 @@
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
- data = (unsigned char *)TclGetStringFromObj(objv[objc - 1], &count);
+ data = (unsigned char *)Tcl_GetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
@@ -2644,11 +2627,11 @@
case OPT_WRAPCHAR:
wrapchar = (const char *)Tcl_GetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
- wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
+ wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
@@ -2769,11 +2752,11 @@
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
break;
case OPT_WRAPCHAR:
- wrapchar = (const unsigned char *)TclGetStringFromObj(
+ wrapchar = (const unsigned char *)Tcl_GetStringFromObj(
objv[i + 1], &wrapcharlen);
{
const unsigned char *p = wrapchar;
Tcl_Size numBytes = wrapcharlen;
@@ -2914,11 +2897,11 @@
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
- data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ 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);
@@ -3089,11 +3072,11 @@
TclNewObj(resultObj);
data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
- data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
+ 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);
Index: generic/tclCkalloc.c
==================================================================
--- generic/tclCkalloc.c
+++ generic/tclCkalloc.c
@@ -1,21 +1,33 @@
/*
- * tclCkalloc.c --
- *
- * Interface to malloc and free that provides support for debugging
- * problems involving overwritten, double freeing memory and loss of
- * memory.
- *
* 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
#define FALSE 0
Index: generic/tclClock.c
==================================================================
--- generic/tclClock.c
+++ generic/tclClock.c
@@ -1,58 +1,134 @@
/*
- * tclClock.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.
- *
* Copyright © 1991-1995 Karl Lehenbauer & Mark Diekhans.
* 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.
+*/
+
+/*
+ * tclClock.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"
-#include "tclStrIdxTree.h"
-#include "tclDate.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 hath[2][12] = {
- {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31},
- {31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}
-};
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]
*/
-CLOCK_LITERAL_ARRAY(Literals);
+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"
+};
-/* Msgcat literals for exact match (mcKey) */
-CLOCK_LOCALE_LITERAL_ARRAY(MsgCtLiterals, "");
-/* Msgcat index literals prefixed with _IDX_, used for quick dictionary search */
-CLOCK_LOCALE_LITERAL_ARRAY(MsgCtLitIdxs, "_IDX_");
+/*
+ * 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.
@@ -69,88 +145,69 @@
/*
* 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[],
- Tcl_WideInt *rangesVal);
+ TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int ConvertUTCToLocalUsingC(Tcl_Interp *,
TclDateFields *, int);
-static int ConvertLocalToUTC(ClockClientData *, Tcl_Interp *,
- TclDateFields *, Tcl_Obj *timezoneObj, int);
+static int ConvertLocalToUTC(Tcl_Interp *,
+ TclDateFields *, Tcl_Obj *, int);
static int ConvertLocalToUTCUsingTable(Tcl_Interp *,
- TclDateFields *, int, Tcl_Obj *const[],
- Tcl_WideInt *rangesVal);
+ TclDateFields *, Tcl_Size, Tcl_Obj *const[]);
static int ConvertLocalToUTCUsingC(Tcl_Interp *,
TclDateFields *, int);
-static int ClockConfigureObjCmd(void *clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+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 int ClockGetDateFields(ClockClientData *,
- Tcl_Interp *interp, TclDateFields *fields,
- Tcl_Obj *timezoneObj, int changeover);
-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 ClockSecondsObjCmd;
-static Tcl_ObjCmdProc ClockFormatObjCmd;
-static Tcl_ObjCmdProc ClockScanObjCmd;
-static int ClockScanCommit(DateInfo *info,
- ClockFmtScnCmdArgs *opts);
-static int ClockFreeScan(DateInfo *info,
- Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts);
-static int ClockCalcRelTime(DateInfo *info);
-static Tcl_ObjCmdProc ClockAddObjCmd;
-static int ClockValidDate(DateInfo *,
- ClockFmtScnCmdArgs *, int stage);
+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 size_t TzsetIfNecessary(void);
+static void TzsetIfNecessary(void);
static void ClockDeleteCmdProc(void *);
-static Tcl_ObjCmdProc ClockSafeCatchCmd;
-static void ClockFinalize(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 "::tcl::clock::". When NULL marks
* the end of the table. */
- Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
+ Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
* will always have the ClockClientData sent
* to it, but may well ignore this data. */
- CompileProc *compileProc; /* The compiler for the command. */
- void *clientData; /* Any clientData to give the command (if NULL
- * a reference to ClockClientData will be sent) */
};
static const struct ClockCommand clockCommands[] = {
- {"add", ClockAddObjCmd, TclCompileBasicMin1ArgCmd, NULL},
- {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL},
- {"format", ClockFormatObjCmd, TclCompileBasicMin1ArgCmd, NULL},
- {"getenv", ClockGetenvObjCmd, TclCompileBasicMin1ArgCmd, NULL},
- {"microseconds", ClockMicrosecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(1)},
- {"milliseconds", ClockMillisecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(2)},
- {"scan", ClockScanObjCmd, TclCompileBasicMin1ArgCmd, NULL},
- {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, INT2PTR(3)},
- {"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd, NULL, NULL},
- {"GetDateFields", ClockGetdatefieldsObjCmd, NULL, NULL},
+ {"getenv", ClockGetenvObjCmd},
+ {"Oldscan", TclClockOldscanObjCmd},
+ {"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd},
+ {"GetDateFields", ClockGetdatefieldsObjCmd},
{"GetJulianDayFromEraYearMonthDay",
- ClockGetjuliandayfromerayearmonthdayObjCmd, NULL, NULL},
+ ClockGetjuliandayfromerayearmonthdayObjCmd},
{"GetJulianDayFromEraYearWeekDay",
- ClockGetjuliandayfromerayearweekdayObjCmd, NULL, NULL},
- {"catch", ClockSafeCatchCmd, TclCompileBasicMin1ArgCmd, NULL},
- {NULL, NULL, NULL, NULL}
+ ClockGetjuliandayfromerayearweekdayObjCmd},
+ {"ParseFormatArgs", ClockParseformatargsObjCmd},
+ {NULL, NULL}
};
/*
*----------------------------------------------------------------------
*
@@ -175,22 +232,25 @@
{
const struct ClockCommand *clockCmdPtr;
char cmdName[50]; /* Buffer large enough to hold the string
*::tcl::clock::GetJulianDayFromEraYearMonthDay
* plus a terminating NUL. */
- Command *cmdPtr;
ClockClientData *data;
int i;
- static int initialized = 0; /* global clock engine initialized (in process) */
- /*
- * Register handler to finalize clock on exit.
- */
- if (!initialized) {
- Tcl_CreateExitHandler(ClockFinalize, NULL);
- initialized = 1;
- }
+ /* 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.
*/
@@ -205,1182 +265,31 @@
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) {
- TclInitObjRef(data->literals[i], Tcl_NewStringObj(
- Literals[i], TCL_AUTO_LENGTH));
- }
- data->mcLiterals = NULL;
- data->mcLitIdxs = NULL;
- data->mcDicts = NULL;
- data->lastTZEpoch = 0;
- data->currentYearCentury = ClockDefaultYearCentury;
- data->yearOfCenturySwitch = ClockDefaultCenturySwitch;
- data->validMinYear = INT_MIN;
- data->validMaxYear = INT_MAX;
- /* corresponds max of JDN in sqlite - 9999-12-31 23:59:59 per default */
- data->maxJDN = 5373484.499999994;
-
- data->systemTimeZone = NULL;
- data->systemSetupTZData = NULL;
- data->gmtSetupTimeZoneUnnorm = NULL;
- data->gmtSetupTimeZone = NULL;
- data->gmtSetupTZData = NULL;
- data->gmtTZName = NULL;
- data->lastSetupTimeZoneUnnorm = NULL;
- data->lastSetupTimeZone = NULL;
- data->lastSetupTZData = NULL;
- data->prevSetupTimeZoneUnnorm = NULL;
- data->prevSetupTimeZone = NULL;
- data->prevSetupTZData = NULL;
-
- data->defaultLocale = NULL;
- data->defaultLocaleDict = NULL;
- data->currentLocale = NULL;
- data->currentLocaleDict = NULL;
- data->lastUsedLocaleUnnorm = NULL;
- data->lastUsedLocale = NULL;
- data->lastUsedLocaleDict = NULL;
- data->prevUsedLocaleUnnorm = NULL;
- data->prevUsedLocale = NULL;
- data->prevUsedLocaleDict = NULL;
-
- data->lastBase.timezoneObj = NULL;
-
- memset(&data->lastTZOffsCache, 0, sizeof(data->lastTZOffsCache));
-
- data->defFlags = CLF_VALIDATE;
+ 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 14 /* == strlen("::tcl::clock::") */
memcpy(cmdName, "::tcl::clock::", TCL_CLOCK_PREFIX_LEN);
for (clockCmdPtr=clockCommands ; clockCmdPtr->name!=NULL ; clockCmdPtr++) {
- void *clientData;
-
strcpy(cmdName + TCL_CLOCK_PREFIX_LEN, clockCmdPtr->name);
- if (!(clientData = clockCmdPtr->clientData)) {
- clientData = data;
- data->refCount++;
- }
- cmdPtr = (Command *)Tcl_CreateObjCommand(interp, cmdName,
- clockCmdPtr->objCmdProc, clientData,
- clockCmdPtr->clientData ? NULL : ClockDeleteCmdProc);
- cmdPtr->compileProc = clockCmdPtr->compileProc ?
- clockCmdPtr->compileProc : TclCompileBasicMin0ArgCmd;
- }
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
- "::tcl::unsupported::clock::configure",
- ClockConfigureObjCmd, data, ClockDeleteCmdProc);
- data->refCount++;
- cmdPtr->compileProc = TclCompileBasicMin0ArgCmd;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockConfigureClear --
- *
- * Clean up cached resp. run-time storages used in clock commands.
- *
- * Shared usage for clean-up (ClockDeleteCmdProc) and "configure -clear".
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ClockConfigureClear(
- ClockClientData *data)
-{
- ClockFrmScnClearCaches();
-
- data->lastTZEpoch = 0;
- TclUnsetObjRef(data->systemTimeZone);
- TclUnsetObjRef(data->systemSetupTZData);
- TclUnsetObjRef(data->gmtSetupTimeZoneUnnorm);
- TclUnsetObjRef(data->gmtSetupTimeZone);
- TclUnsetObjRef(data->gmtSetupTZData);
- TclUnsetObjRef(data->gmtTZName);
- TclUnsetObjRef(data->lastSetupTimeZoneUnnorm);
- TclUnsetObjRef(data->lastSetupTimeZone);
- TclUnsetObjRef(data->lastSetupTZData);
- TclUnsetObjRef(data->prevSetupTimeZoneUnnorm);
- TclUnsetObjRef(data->prevSetupTimeZone);
- TclUnsetObjRef(data->prevSetupTZData);
-
- TclUnsetObjRef(data->defaultLocale);
- data->defaultLocaleDict = NULL;
- TclUnsetObjRef(data->currentLocale);
- data->currentLocaleDict = NULL;
- TclUnsetObjRef(data->lastUsedLocaleUnnorm);
- TclUnsetObjRef(data->lastUsedLocale);
- data->lastUsedLocaleDict = NULL;
- TclUnsetObjRef(data->prevUsedLocaleUnnorm);
- TclUnsetObjRef(data->prevUsedLocale);
- data->prevUsedLocaleDict = NULL;
-
- TclUnsetObjRef(data->lastBase.timezoneObj);
-
- TclUnsetObjRef(data->lastTZOffsCache[0].timezoneObj);
- TclUnsetObjRef(data->lastTZOffsCache[0].tzName);
- TclUnsetObjRef(data->lastTZOffsCache[1].timezoneObj);
- TclUnsetObjRef(data->lastTZOffsCache[1].tzName);
-
- TclUnsetObjRef(data->mcDicts);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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]);
- }
- if (data->mcLiterals != NULL) {
- for (i = 0; i < MCLIT__END; ++i) {
- Tcl_DecrRefCount(data->mcLiterals[i]);
- }
- Tcl_Free(data->mcLiterals);
- data->mcLiterals = NULL;
- }
- if (data->mcLitIdxs != NULL) {
- for (i = 0; i < MCLIT__END; ++i) {
- Tcl_DecrRefCount(data->mcLitIdxs[i]);
- }
- Tcl_Free(data->mcLitIdxs);
- data->mcLitIdxs = NULL;
- }
-
- ClockConfigureClear(data);
-
- Tcl_Free(data->literals);
- Tcl_Free(data);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SavePrevTimezoneObj --
- *
- * Used to store previously used/cached time zone (makes it reusable).
- *
- * This enables faster switch between time zones (e. g. to convert from
- * one to another).
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-static inline void
-SavePrevTimezoneObj(
- ClockClientData *dataPtr) /* Client data containing literal pool */
-{
- Tcl_Obj *timezoneObj = dataPtr->lastSetupTimeZone;
-
- if (timezoneObj && timezoneObj != dataPtr->prevSetupTimeZone) {
- TclSetObjRef(dataPtr->prevSetupTimeZoneUnnorm, dataPtr->lastSetupTimeZoneUnnorm);
- TclSetObjRef(dataPtr->prevSetupTimeZone, timezoneObj);
- TclSetObjRef(dataPtr->prevSetupTZData, dataPtr->lastSetupTZData);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NormTimezoneObj --
- *
- * Normalizes the timezone object (used for caching puposes).
- *
- * If already cached time zone could be found, returns this
- * object (last setup or last used, system (current) or gmt).
- *
- * Results:
- * Normalized tcl object pointer.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-NormTimezoneObj(
- ClockClientData *dataPtr, /* Client data containing literal pool */
- Tcl_Obj *timezoneObj, /* Name of zone to find */
- int *loaded) /* Used to recognized TZ was loaded */
-{
- const char *tz;
-
- *loaded = 1;
- if (timezoneObj == dataPtr->lastSetupTimeZoneUnnorm
- && dataPtr->lastSetupTimeZone != NULL) {
- return dataPtr->lastSetupTimeZone;
- }
- if (timezoneObj == dataPtr->prevSetupTimeZoneUnnorm
- && dataPtr->prevSetupTimeZone != NULL) {
- return dataPtr->prevSetupTimeZone;
- }
- if (timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm
- && dataPtr->gmtSetupTimeZone != NULL) {
- return dataPtr->literals[LIT_GMT];
- }
- if (timezoneObj == dataPtr->lastSetupTimeZone
- || timezoneObj == dataPtr->prevSetupTimeZone
- || timezoneObj == dataPtr->gmtSetupTimeZone
- || timezoneObj == dataPtr->systemTimeZone) {
- return timezoneObj;
- }
-
- tz = TclGetString(timezoneObj);
- if (dataPtr->lastSetupTimeZone != NULL
- && strcmp(tz, TclGetString(dataPtr->lastSetupTimeZone)) == 0) {
- TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);
- return dataPtr->lastSetupTimeZone;
- }
- if (dataPtr->prevSetupTimeZone != NULL
- && strcmp(tz, TclGetString(dataPtr->prevSetupTimeZone)) == 0) {
- TclSetObjRef(dataPtr->prevSetupTimeZoneUnnorm, timezoneObj);
- return dataPtr->prevSetupTimeZone;
- }
- if (dataPtr->systemTimeZone != NULL
- && strcmp(tz, TclGetString(dataPtr->systemTimeZone)) == 0) {
- return dataPtr->systemTimeZone;
- }
- if (strcmp(tz, Literals[LIT_GMT]) == 0) {
- TclSetObjRef(dataPtr->gmtSetupTimeZoneUnnorm, timezoneObj);
- if (dataPtr->gmtSetupTimeZone == NULL) {
- *loaded = 0;
- }
- return dataPtr->literals[LIT_GMT];
- }
- /* unknown/unloaded tz - recache/revalidate later as last-setup if needed */
- *loaded = 0;
- return timezoneObj;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockGetSystemLocale --
- *
- * Returns system locale.
- *
- * Executes ::tcl::clock::GetSystemLocale in given interpreter.
- *
- * Results:
- * Returns system locale tcl object.
- *
- *----------------------------------------------------------------------
- */
-
-static inline Tcl_Obj *
-ClockGetSystemLocale(
- ClockClientData *dataPtr, /* Opaque pointer to literal pool, etc. */
- Tcl_Interp *interp) /* Tcl interpreter */
-{
- if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETSYSTEMLOCALE], 0) != TCL_OK) {
- return NULL;
- }
-
- return Tcl_GetObjResult(interp);
-}
-/*
- *----------------------------------------------------------------------
- *
- * ClockGetCurrentLocale --
- *
- * Returns current locale.
- *
- * Executes ::tcl::clock::mclocale in given interpreter.
- *
- * Results:
- * Returns current locale tcl object.
- *
- *----------------------------------------------------------------------
- */
-
-static inline Tcl_Obj *
-ClockGetCurrentLocale(
- ClockClientData *dataPtr, /* Client data containing literal pool */
- Tcl_Interp *interp) /* Tcl interpreter */
-{
- if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETCURRENTLOCALE], 0) != TCL_OK) {
- return NULL;
- }
-
- TclSetObjRef(dataPtr->currentLocale, Tcl_GetObjResult(interp));
- dataPtr->currentLocaleDict = NULL;
- Tcl_ResetResult(interp);
-
- return dataPtr->currentLocale;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SavePrevLocaleObj --
- *
- * Used to store previously used/cached locale (makes it reusable).
- *
- * This enables faster switch between locales (e. g. to convert from one to another).
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static inline void
-SavePrevLocaleObj(
- ClockClientData *dataPtr) /* Client data containing literal pool */
-{
- Tcl_Obj *localeObj = dataPtr->lastUsedLocale;
-
- if (localeObj && localeObj != dataPtr->prevUsedLocale) {
- TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, dataPtr->lastUsedLocaleUnnorm);
- TclSetObjRef(dataPtr->prevUsedLocale, localeObj);
- /* mcDicts owns reference to dict */
- dataPtr->prevUsedLocaleDict = dataPtr->lastUsedLocaleDict;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NormLocaleObj --
- *
- * Normalizes the locale object (used for caching puposes).
- *
- * If already cached locale could be found, returns this
- * object (current, system (OS) or last used locales).
- *
- * Results:
- * Normalized tcl object pointer.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-NormLocaleObj(
- ClockClientData *dataPtr, /* Client data containing literal pool */
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *localeObj,
- Tcl_Obj **mcDictObj)
-{
- const char *loc, *loc2;
-
- if (localeObj == NULL
- || localeObj == dataPtr->literals[LIT_C]
- || localeObj == dataPtr->defaultLocale) {
- *mcDictObj = dataPtr->defaultLocaleDict;
- return dataPtr->defaultLocale ?
- dataPtr->defaultLocale : dataPtr->literals[LIT_C];
- }
-
- if (localeObj == dataPtr->currentLocale
- || localeObj == dataPtr->literals[LIT_CURRENT]) {
- if (dataPtr->currentLocale == NULL) {
- ClockGetCurrentLocale(dataPtr, interp);
- }
- *mcDictObj = dataPtr->currentLocaleDict;
- return dataPtr->currentLocale;
- }
-
- if (localeObj == dataPtr->lastUsedLocale
- || localeObj == dataPtr->lastUsedLocaleUnnorm) {
- *mcDictObj = dataPtr->lastUsedLocaleDict;
- return dataPtr->lastUsedLocale;
- }
-
- if (localeObj == dataPtr->prevUsedLocale
- || localeObj == dataPtr->prevUsedLocaleUnnorm) {
- *mcDictObj = dataPtr->prevUsedLocaleDict;
- return dataPtr->prevUsedLocale;
- }
-
- loc = TclGetString(localeObj);
- if (dataPtr->currentLocale != NULL
- && (localeObj == dataPtr->currentLocale
- || (localeObj->length == dataPtr->currentLocale->length
- && strcasecmp(loc, TclGetString(dataPtr->currentLocale)) == 0))) {
- *mcDictObj = dataPtr->currentLocaleDict;
- return dataPtr->currentLocale;
- }
-
- if (dataPtr->lastUsedLocale != NULL
- && (localeObj == dataPtr->lastUsedLocale
- || (localeObj->length == dataPtr->lastUsedLocale->length
- && strcasecmp(loc, TclGetString(dataPtr->lastUsedLocale)) == 0))) {
- *mcDictObj = dataPtr->lastUsedLocaleDict;
- TclSetObjRef(dataPtr->lastUsedLocaleUnnorm, localeObj);
- return dataPtr->lastUsedLocale;
- }
-
- if (dataPtr->prevUsedLocale != NULL
- && (localeObj == dataPtr->prevUsedLocale
- || (localeObj->length == dataPtr->prevUsedLocale->length
- && strcasecmp(loc, TclGetString(dataPtr->prevUsedLocale)) == 0))) {
- *mcDictObj = dataPtr->prevUsedLocaleDict;
- TclSetObjRef(dataPtr->prevUsedLocaleUnnorm, localeObj);
- return dataPtr->prevUsedLocale;
- }
-
- if ((localeObj->length == 1 /* C */
- && strcasecmp(loc, Literals[LIT_C]) == 0)
- || (dataPtr->defaultLocale && (loc2 = TclGetString(dataPtr->defaultLocale))
- && localeObj->length == dataPtr->defaultLocale->length
- && strcasecmp(loc, loc2) == 0)) {
- *mcDictObj = dataPtr->defaultLocaleDict;
- return dataPtr->defaultLocale ?
- dataPtr->defaultLocale : dataPtr->literals[LIT_C];
- }
-
- if (localeObj->length == 7 /* current */
- && strcasecmp(loc, Literals[LIT_CURRENT]) == 0) {
- if (dataPtr->currentLocale == NULL) {
- ClockGetCurrentLocale(dataPtr, interp);
- }
- *mcDictObj = dataPtr->currentLocaleDict;
- return dataPtr->currentLocale;
- }
-
- if ((localeObj->length == 6 /* system */
- && strcasecmp(loc, Literals[LIT_SYSTEM]) == 0)) {
- SavePrevLocaleObj(dataPtr);
- TclSetObjRef(dataPtr->lastUsedLocaleUnnorm, localeObj);
- localeObj = ClockGetSystemLocale(dataPtr, interp);
- TclSetObjRef(dataPtr->lastUsedLocale, localeObj);
- *mcDictObj = NULL;
- return localeObj;
- }
-
- *mcDictObj = NULL;
- return localeObj;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCDict --
- *
- * Retrieves a localized storage dictionary object for the given
- * locale object.
- *
- * This corresponds with call `::tcl::clock::mcget locale`.
- * Cached representation stored in options (for further access).
- *
- * Results:
- * Tcl-object contains smart reference to msgcat dictionary.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-ClockMCDict(
- ClockFmtScnCmdArgs *opts)
-{
- ClockClientData *dataPtr = opts->dataPtr;
-
- /* if dict not yet retrieved */
- if (opts->mcDictObj == NULL) {
-
- /* if locale was not yet used */
- if (!(opts->flags & CLF_LOCALE_USED)) {
- opts->localeObj = NormLocaleObj(dataPtr, opts->interp,
- opts->localeObj, &opts->mcDictObj);
-
- if (opts->localeObj == NULL) {
- Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
- "locale not specified and no default locale set",
- TCL_AUTO_LENGTH));
- Tcl_SetErrorCode(opts->interp, "CLOCK", "badOption", (char *)NULL);
- return NULL;
- }
- opts->flags |= CLF_LOCALE_USED;
-
- /* check locale literals already available (on demand creation) */
- if (dataPtr->mcLiterals == NULL) {
- int i;
-
- dataPtr->mcLiterals = (Tcl_Obj **)
- Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*));
- for (i = 0; i < MCLIT__END; ++i) {
- TclInitObjRef(dataPtr->mcLiterals[i], Tcl_NewStringObj(
- MsgCtLiterals[i], TCL_AUTO_LENGTH));
- }
- }
- }
-
- /* check or obtain mcDictObj (be sure it's modifiable) */
- if (opts->mcDictObj == NULL || opts->mcDictObj->refCount > 1) {
- Tcl_Size ref = 1;
-
- /* first try to find locale catalog dict */
- if (dataPtr->mcDicts == NULL) {
- TclSetObjRef(dataPtr->mcDicts, Tcl_NewDictObj());
- }
- Tcl_DictObjGet(NULL, dataPtr->mcDicts,
- opts->localeObj, &opts->mcDictObj);
-
- if (opts->mcDictObj == NULL) {
- /* get msgcat dictionary - ::tcl::clock::mcget locale */
- Tcl_Obj *callargs[2];
-
- callargs[0] = dataPtr->literals[LIT_MCGET];
- callargs[1] = opts->localeObj;
-
- if (Tcl_EvalObjv(opts->interp, 2, callargs, 0) != TCL_OK) {
- return NULL;
- }
-
- opts->mcDictObj = Tcl_GetObjResult(opts->interp);
- Tcl_ResetResult(opts->interp);
- ref = 0; /* new object is not yet referenced */
- }
-
- /* be sure that object reference doesn't increase (dict changeable) */
- if (opts->mcDictObj->refCount > ref) {
- /* smart reference (shared dict as object with no ref-counter) */
- opts->mcDictObj = TclDictObjSmartRef(opts->interp,
- opts->mcDictObj);
- }
-
- /* create exactly one reference to catalog / make it searchable for future */
- Tcl_DictObjPut(NULL, dataPtr->mcDicts, opts->localeObj,
- opts->mcDictObj);
-
- if (opts->localeObj == dataPtr->literals[LIT_C]
- || opts->localeObj == dataPtr->defaultLocale) {
- dataPtr->defaultLocaleDict = opts->mcDictObj;
- }
- if (opts->localeObj == dataPtr->currentLocale) {
- dataPtr->currentLocaleDict = opts->mcDictObj;
- } else if (opts->localeObj == dataPtr->lastUsedLocale) {
- dataPtr->lastUsedLocaleDict = opts->mcDictObj;
- } else {
- SavePrevLocaleObj(dataPtr);
- TclSetObjRef(dataPtr->lastUsedLocale, opts->localeObj);
- TclUnsetObjRef(dataPtr->lastUsedLocaleUnnorm);
- dataPtr->lastUsedLocaleDict = opts->mcDictObj;
- }
- }
- }
-
- return opts->mcDictObj;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCGet --
- *
- * Retrieves a msgcat value for the given literal integer mcKey
- * from localized storage (corresponding given locale object)
- * by mcLiterals[mcKey] (e. g. MONTHS_FULL).
- *
- * Results:
- * Tcl-object contains localized value.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-ClockMCGet(
- ClockFmtScnCmdArgs *opts,
- int mcKey)
-{
- Tcl_Obj *valObj = NULL;
-
- if (opts->mcDictObj == NULL) {
- ClockMCDict(opts);
- if (opts->mcDictObj == NULL) {
- return NULL;
- }
- }
-
- Tcl_DictObjGet(opts->interp, opts->mcDictObj,
- opts->dataPtr->mcLiterals[mcKey], &valObj);
- return valObj; /* or NULL in obscure case if Tcl_DictObjGet failed */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCGetIdx --
- *
- * Retrieves an indexed msgcat value for the given literal integer mcKey
- * from localized storage (corresponding given locale object)
- * by mcLitIdxs[mcKey] (e. g. _IDX_MONTHS_FULL).
- *
- * Results:
- * Tcl-object contains localized indexed value.
- *
- *----------------------------------------------------------------------
- */
-
-MODULE_SCOPE Tcl_Obj *
-ClockMCGetIdx(
- ClockFmtScnCmdArgs *opts,
- int mcKey)
-{
- ClockClientData *dataPtr = opts->dataPtr;
- Tcl_Obj *valObj = NULL;
-
- if (opts->mcDictObj == NULL) {
- ClockMCDict(opts);
- if (opts->mcDictObj == NULL) {
- return NULL;
- }
- }
-
- /* try to get indices object */
- if (dataPtr->mcLitIdxs == NULL) {
- return NULL;
- }
-
- if (Tcl_DictObjGet(NULL, opts->mcDictObj,
- dataPtr->mcLitIdxs[mcKey], &valObj) != TCL_OK) {
- return NULL;
- }
- return valObj;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCSetIdx --
- *
- * Sets an indexed msgcat value for the given literal integer mcKey
- * in localized storage (corresponding given locale object)
- * by mcLitIdxs[mcKey] (e. g. _IDX_MONTHS_FULL).
- *
- * Results:
- * Returns a standard Tcl result.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockMCSetIdx(
- ClockFmtScnCmdArgs *opts,
- int mcKey,
- Tcl_Obj *valObj)
-{
- ClockClientData *dataPtr = opts->dataPtr;
-
- if (opts->mcDictObj == NULL) {
- ClockMCDict(opts);
- if (opts->mcDictObj == NULL) {
- return TCL_ERROR;
- }
- }
-
- /* if literal storage for indices not yet created */
- if (dataPtr->mcLitIdxs == NULL) {
- int i;
-
- dataPtr->mcLitIdxs = (Tcl_Obj **)Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*));
- for (i = 0; i < MCLIT__END; ++i) {
- TclInitObjRef(dataPtr->mcLitIdxs[i],
- Tcl_NewStringObj(MsgCtLitIdxs[i], TCL_AUTO_LENGTH));
- }
- }
-
- return Tcl_DictObjPut(opts->interp, opts->mcDictObj,
- dataPtr->mcLitIdxs[mcKey], valObj);
-}
-
-static void
-TimezoneLoaded(
- ClockClientData *dataPtr,
- Tcl_Obj *timezoneObj, /* Name of zone was loaded */
- Tcl_Obj *tzUnnormObj) /* Name of zone was loaded */
-{
- /* don't overwrite last-setup with GMT (special case) */
- if (timezoneObj == dataPtr->literals[LIT_GMT]) {
- /* mark GMT zone loaded */
- if (dataPtr->gmtSetupTimeZone == NULL) {
- TclSetObjRef(dataPtr->gmtSetupTimeZone,
- dataPtr->literals[LIT_GMT]);
- }
- TclSetObjRef(dataPtr->gmtSetupTimeZoneUnnorm, tzUnnormObj);
- return;
- }
-
- /* last setup zone loaded */
- if (dataPtr->lastSetupTimeZone != timezoneObj) {
- SavePrevTimezoneObj(dataPtr);
- TclSetObjRef(dataPtr->lastSetupTimeZone, timezoneObj);
- TclUnsetObjRef(dataPtr->lastSetupTZData);
- }
- TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, tzUnnormObj);
-}
-/*
- *----------------------------------------------------------------------
- *
- * ClockConfigureObjCmd --
- *
- * This function is invoked to process the Tcl "::clock::configure" (internal) command.
- *
- * Usage:
- * ::tcl::unsupported::clock::configure ?-option ?value??
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ClockConfigureObjCmd(
- 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;
- static const char *const options[] = {
- "-system-tz", "-setup-tz", "-default-locale", "-current-locale",
- "-clear",
- "-year-century", "-century-switch",
- "-min-year", "-max-year", "-max-jdn", "-validate",
- "-init-complete",
- NULL
- };
- enum optionInd {
- CLOCK_SYSTEM_TZ, CLOCK_SETUP_TZ, CLOCK_DEFAULT_LOCALE, CLOCK_CURRENT_LOCALE,
- CLOCK_CLEAR_CACHE,
- CLOCK_YEAR_CENTURY, CLOCK_CENTURY_SWITCH,
- CLOCK_MIN_YEAR, CLOCK_MAX_YEAR, CLOCK_MAX_JDN, CLOCK_VALIDATE,
- CLOCK_INIT_COMPLETE
- };
- int optionIndex; /* Index of an option. */
- Tcl_Size i;
-
- for (i = 1; i < objc; i++) {
- if (Tcl_GetIndexFromObj(interp, objv[i++], options,
- "option", 0, &optionIndex) != TCL_OK) {
- Tcl_SetErrorCode(interp, "CLOCK", "badOption",
- TclGetString(objv[i - 1]), (char *)NULL);
- return TCL_ERROR;
- }
- switch (optionIndex) {
- case CLOCK_SYSTEM_TZ: {
- /* validate current tz-epoch */
- size_t lastTZEpoch = TzsetIfNecessary();
-
- if (i < objc) {
- if (dataPtr->systemTimeZone != objv[i]) {
- TclSetObjRef(dataPtr->systemTimeZone, objv[i]);
- TclUnsetObjRef(dataPtr->systemSetupTZData);
- }
- dataPtr->lastTZEpoch = lastTZEpoch;
- }
- if (i + 1 >= objc && dataPtr->systemTimeZone != NULL
- && dataPtr->lastTZEpoch == lastTZEpoch) {
- Tcl_SetObjResult(interp, dataPtr->systemTimeZone);
- }
- break;
- }
- case CLOCK_SETUP_TZ:
- if (i < objc) {
- int loaded;
- Tcl_Obj *timezoneObj = NormTimezoneObj(dataPtr, objv[i], &loaded);
-
- if (!loaded) {
- TimezoneLoaded(dataPtr, timezoneObj, objv[i]);
- }
- Tcl_SetObjResult(interp, timezoneObj);
- } else if (i + 1 >= objc && dataPtr->lastSetupTimeZone != NULL) {
- Tcl_SetObjResult(interp, dataPtr->lastSetupTimeZone);
- }
- break;
- case CLOCK_DEFAULT_LOCALE:
- if (i < objc) {
- if (dataPtr->defaultLocale != objv[i]) {
- TclSetObjRef(dataPtr->defaultLocale, objv[i]);
- dataPtr->defaultLocaleDict = NULL;
- }
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp, dataPtr->defaultLocale ?
- dataPtr->defaultLocale : dataPtr->literals[LIT_C]);
- }
- break;
- case CLOCK_CURRENT_LOCALE:
- if (i < objc) {
- if (dataPtr->currentLocale != objv[i]) {
- TclSetObjRef(dataPtr->currentLocale, objv[i]);
- dataPtr->currentLocaleDict = NULL;
- }
- }
- if (i + 1 >= objc && dataPtr->currentLocale != NULL) {
- Tcl_SetObjResult(interp, dataPtr->currentLocale);
- }
- break;
- case CLOCK_YEAR_CENTURY:
- if (i < objc) {
- int year;
-
- if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
- return TCL_ERROR;
- }
- dataPtr->currentYearCentury = year;
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp, objv[i]);
- }
- continue;
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj(dataPtr->currentYearCentury));
- }
- break;
- case CLOCK_CENTURY_SWITCH:
- if (i < objc) {
- int year;
-
- if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
- return TCL_ERROR;
- }
- dataPtr->yearOfCenturySwitch = year;
- Tcl_SetObjResult(interp, objv[i]);
- continue;
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj(dataPtr->yearOfCenturySwitch));
- }
- break;
- case CLOCK_MIN_YEAR:
- if (i < objc) {
- int year;
-
- if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
- return TCL_ERROR;
- }
- dataPtr->validMinYear = year;
- Tcl_SetObjResult(interp, objv[i]);
- continue;
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj(dataPtr->validMinYear));
- }
- break;
- case CLOCK_MAX_YEAR:
- if (i < objc) {
- int year;
-
- if (TclGetIntFromObj(interp, objv[i], &year) != TCL_OK) {
- return TCL_ERROR;
- }
- dataPtr->validMaxYear = year;
- Tcl_SetObjResult(interp, objv[i]);
- continue;
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp,
- Tcl_NewWideIntObj(dataPtr->validMaxYear));
- }
- break;
- case CLOCK_MAX_JDN:
- if (i < objc) {
- double jd;
-
- if (Tcl_GetDoubleFromObj(interp, objv[i], &jd) != TCL_OK) {
- return TCL_ERROR;
- }
- dataPtr->maxJDN = jd;
- Tcl_SetObjResult(interp, objv[i]);
- continue;
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dataPtr->maxJDN));
- }
- break;
- case CLOCK_VALIDATE:
- if (i < objc) {
- int val;
-
- if (Tcl_GetBooleanFromObj(interp, objv[i], &val) != TCL_OK) {
- return TCL_ERROR;
- }
- if (val) {
- dataPtr->defFlags |= CLF_VALIDATE;
- } else {
- dataPtr->defFlags &= ~CLF_VALIDATE;
- }
- }
- if (i + 1 >= objc) {
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj(dataPtr->defFlags & CLF_VALIDATE));
- }
- break;
- case CLOCK_CLEAR_CACHE:
- ClockConfigureClear(dataPtr);
- break;
- case CLOCK_INIT_COMPLETE: {
- /*
- * Init completed.
- * Compile clock ensemble (performance purposes).
- */
- Tcl_Command token = Tcl_FindCommand(interp, "::clock",
- NULL, TCL_GLOBAL_ONLY);
- if (!token) {
- return TCL_ERROR;
- }
- int ensFlags = 0;
- if (Tcl_GetEnsembleFlags(interp, token, &ensFlags) != TCL_OK) {
- return TCL_ERROR;
- }
- ensFlags |= ENSEMBLE_COMPILE;
- if (Tcl_SetEnsembleFlags(interp, token, ensFlags) != TCL_OK) {
- return TCL_ERROR;
- }
- break;
- }
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockGetTZData --
- *
- * Retrieves tzdata table for given normalized timezone.
- *
- * Results:
- * Returns a tcl object with tzdata.
- *
- * Side effects:
- * The tzdata can be cached in ClockClientData structure.
- *
- *----------------------------------------------------------------------
- */
-
-static inline Tcl_Obj *
-ClockGetTZData(
- ClockClientData *dataPtr, /* Opaque pointer to literal pool, etc. */
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *timezoneObj) /* Name of the timezone */
-{
- Tcl_Obj *ret, **out = NULL;
-
- /* if cached (if already setup this one) */
- if (timezoneObj == dataPtr->lastSetupTimeZone
- || timezoneObj == dataPtr->lastSetupTimeZoneUnnorm) {
- if (dataPtr->lastSetupTZData != NULL) {
- return dataPtr->lastSetupTZData;
- }
- out = &dataPtr->lastSetupTZData;
- }
- /* differentiate GMT and system zones, because used often */
- /* simple caching, because almost used the tz-data of last timezone
- */
- if (timezoneObj == dataPtr->systemTimeZone) {
- if (dataPtr->systemSetupTZData != NULL) {
- return dataPtr->systemSetupTZData;
- }
- out = &dataPtr->systemSetupTZData;
- } else if (timezoneObj == dataPtr->literals[LIT_GMT]
- || timezoneObj == dataPtr->gmtSetupTimeZoneUnnorm) {
- if (dataPtr->gmtSetupTZData != NULL) {
- return dataPtr->gmtSetupTZData;
- }
- out = &dataPtr->gmtSetupTZData;
- } else if (timezoneObj == dataPtr->prevSetupTimeZone
- || timezoneObj == dataPtr->prevSetupTimeZoneUnnorm) {
- if (dataPtr->prevSetupTZData != NULL) {
- return dataPtr->prevSetupTZData;
- }
- out = &dataPtr->prevSetupTZData;
- }
-
- ret = Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA],
- timezoneObj, TCL_LEAVE_ERR_MSG);
-
- /* cache using corresponding slot and as last used */
- if (out != NULL) {
- TclSetObjRef(*out, ret);
- } else if (dataPtr->lastSetupTimeZone != timezoneObj) {
- SavePrevTimezoneObj(dataPtr);
- TclSetObjRef(dataPtr->lastSetupTimeZone, timezoneObj);
- TclUnsetObjRef(dataPtr->lastSetupTimeZoneUnnorm);
- TclSetObjRef(dataPtr->lastSetupTZData, ret);
- }
- return ret;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockGetSystemTimeZone --
- *
- * Returns system (current) timezone.
- *
- * If system zone not yet cached, it executes ::tcl::clock::GetSystemTimeZone
- * in given interpreter and caches its result.
- *
- * Results:
- * Returns normalized timezone object.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-ClockGetSystemTimeZone(
- ClockClientData *dataPtr, /* Pointer to literal pool, etc. */
- Tcl_Interp *interp) /* Tcl interpreter */
-{
- /* if known (cached and same epoch) - return now */
- if (dataPtr->systemTimeZone != NULL
- && dataPtr->lastTZEpoch == TzsetIfNecessary()) {
- return dataPtr->systemTimeZone;
- }
-
- TclUnsetObjRef(dataPtr->systemTimeZone);
- TclUnsetObjRef(dataPtr->systemSetupTZData);
-
- if (Tcl_EvalObjv(interp, 1, &dataPtr->literals[LIT_GETSYSTEMTIMEZONE], 0) != TCL_OK) {
- return NULL;
- }
- if (dataPtr->systemTimeZone == NULL) {
- TclSetObjRef(dataPtr->systemTimeZone, Tcl_GetObjResult(interp));
- }
- Tcl_ResetResult(interp);
- return dataPtr->systemTimeZone;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockSetupTimeZone --
- *
- * Sets up the timezone. Loads tzdata, etc.
- *
- * Results:
- * Returns normalized timezone object.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-ClockSetupTimeZone(
- ClockClientData *dataPtr, /* Pointer to literal pool, etc. */
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *timezoneObj)
-{
- int loaded;
- Tcl_Obj *callargs[2];
-
- /* if cached (if already setup this one) */
- if (timezoneObj == dataPtr->literals[LIT_GMT]
- && dataPtr->gmtSetupTZData != NULL) {
- return timezoneObj;
- }
- if ((timezoneObj == dataPtr->lastSetupTimeZone
- || timezoneObj == dataPtr->lastSetupTimeZoneUnnorm)
- && dataPtr->lastSetupTimeZone != NULL) {
- return dataPtr->lastSetupTimeZone;
- }
- if ((timezoneObj == dataPtr->prevSetupTimeZone
- || timezoneObj == dataPtr->prevSetupTimeZoneUnnorm)
- && dataPtr->prevSetupTimeZone != NULL) {
- return dataPtr->prevSetupTimeZone;
- }
-
- /* differentiate normalized (last, GMT and system) zones, because used often and already set */
- callargs[1] = NormTimezoneObj(dataPtr, timezoneObj, &loaded);
- /* if loaded (setup already called for this TZ) */
- if (loaded) {
- return callargs[1];
- }
-
- /* before setup just take a look in TZData variable */
- if (Tcl_ObjGetVar2(interp, dataPtr->literals[LIT_TZDATA], timezoneObj, 0)) {
- /* put it to last slot and return normalized */
- TimezoneLoaded(dataPtr, callargs[1], timezoneObj);
- return callargs[1];
- }
- /* setup now */
- callargs[0] = dataPtr->literals[LIT_SETUPTIMEZONE];
- if (Tcl_EvalObjv(interp, 2, callargs, 0) == TCL_OK) {
- /* save unnormalized last used */
- TclSetObjRef(dataPtr->lastSetupTimeZoneUnnorm, timezoneObj);
- return callargs[1];
- }
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFormatNumericTimeZone --
- *
- * Formats a time zone as +hhmmss
- *
- * Parameters:
- * z - Time zone in seconds east of Greenwich
- *
- * Results:
- * Returns the time zone object (formatted in a numeric form)
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-ClockFormatNumericTimeZone(
- int z)
-{
- char buf[12 + 1], *p;
-
- if (z < 0) {
- z = -z;
- *buf = '-';
- } else {
- *buf = '+';
- }
- TclItoAw(buf + 1, z / 3600, '0', 2);
- z %= 3600;
- p = TclItoAw(buf + 3, z / 60, '0', 2);
- z %= 60;
- if (z != 0) {
- p = TclItoAw(buf + 5, z, '0', 2);
- }
- return Tcl_NewStringObj(buf, p - buf);
+ data->refCount++;
+ Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data,
+ ClockDeleteCmdProc);
+ }
+
+ /* Make the clock ensemble */
+
+ TclMakeEnsemble(interp, "clock", clockImplMap);
}
/*
*----------------------------------------------------------------------
*
@@ -1388,15 +297,15 @@
*
* Tcl command that converts a UTC time to a local time by whatever means
* is available.
*
* Usage:
- * ::tcl::clock::ConvertUTCToLocal dictionary timezone changeover
+ * ::tcl::clock::ConvertUTCToLocal dictionary tzdata changeover
*
* Parameters:
* dict - Dictionary containing a 'localSeconds' entry.
- * timezone - Time zone
+ * tzdata - Time zone data
* changeover - Julian Day of the adoption of the Gregorian calendar.
*
* Results:
* Returns a standard Tcl result.
*
@@ -1408,45 +317,45 @@
*----------------------------------------------------------------------
*/
static int
ClockConvertlocaltoutcObjCmd(
- void *clientData, /* Literal table */
+ void *clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
- ClockClientData *dataPtr = (ClockClientData *)clientData;
+ ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
int status;
- fields.tzName = NULL;
/*
* Check params and convert time.
*/
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "dict timezone changeover");
+ Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
return TCL_ERROR;
}
dict = objv[1];
- if (Tcl_DictObjGet(interp, dict, dataPtr->literals[LIT_LOCALSECONDS],
+ 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", TCL_AUTO_LENGTH));
+ "found in dictionary", -1));
return TCL_ERROR;
}
- if ((TclGetWideIntFromObj(interp, secondsObj, &fields.localSeconds) != TCL_OK)
- || (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
- || ConvertLocalToUTC(dataPtr, interp, &fields, objv[2], changeover)) {
+ 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
@@ -1456,11 +365,11 @@
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
- status = Tcl_DictObjPut(interp, dict, dataPtr->literals[LIT_SECONDS],
+ status = Tcl_DictObjPut(interp, dict, data->literals[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
@@ -1476,15 +385,16 @@
*
* Tcl command that determines the values that [clock format] will use in
* formatting a date, and populates a dictionary with them.
*
* Usage:
- * ::tcl::clock::GetDateFields seconds timezone changeover
+ * ::tcl::clock::GetDateFields seconds tzdata changeover
*
* Parameters:
* seconds - Time expressed in seconds from the Posix epoch.
- * timezone - Time zone in which time is to be expressed.
+ * 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:
@@ -1498,29 +408,27 @@
*----------------------------------------------------------------------
*/
int
ClockGetdatefieldsObjCmd(
- void *clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
- ClockClientData *dataPtr = (ClockClientData *)clientData;
- Tcl_Obj *const *lit = dataPtr->literals;
+ ClockClientData *data = (ClockClientData *)clientData;
+ Tcl_Obj *const *lit = data->literals;
int changeover;
- fields.tzName = NULL;
-
/*
* Check params.
*/
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "seconds timezone changeover");
+ 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;
@@ -1529,23 +437,39 @@
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
- if (TclHasInternalRep(objv[1], &tclBignumType)) {
+ if (TclHasInternalRep(objv[1], tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
- /* Extract fields */
+ /*
+ * Convert UTC time to local.
+ */
- if (ClockGetDateFields(dataPtr, interp, &fields, objv[2],
- changeover) != TCL_OK) {
+ if (ConvertUTCToLocal(interp, &fields, objv[2], changeover) != TCL_OK) {
return TCL_ERROR;
}
- /* Make dict of fields */
+ /*
+ * 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],
@@ -1574,62 +498,10 @@
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockGetDateFields --
- *
- * Converts given UTC time (seconds in a TclDateFields structure)
- * to local time and determines the values that clock routines will
- * use in scanning or formatting a date.
- *
- * Results:
- * Date-time values are stored in structure "fields".
- * Returns a standard Tcl result.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockGetDateFields(
- ClockClientData *dataPtr, /* Literal pool, etc. */
- Tcl_Interp *interp, /* Tcl interpreter */
- TclDateFields *fields, /* Pointer to result fields, where
- * fields->seconds contains date to extract */
- Tcl_Obj *timezoneObj, /* Time zone object or NULL for gmt */
- int changeover) /* Julian Day Number */
-{
- /*
- * Convert UTC time to local.
- */
-
- if (ConvertUTCToLocal(dataPtr, interp, fields, timezoneObj,
- changeover) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Extract Julian day and seconds of the day.
- */
-
- ClockExtractJDAndSODFromSeconds(fields->julianDay, fields->secondOfDay,
- fields->localSeconds);
-
- /*
- * Convert to Julian or Gregorian calendar.
- */
-
- GetGregorianEraYearDay(fields, changeover);
- GetMonthDay(fields);
- GetYearWeekDay(fields, changeover);
-
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -1664,11 +536,11 @@
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", TCL_AUTO_LENGTH));
+ "expected key(s) not found in dictionary", -1));
return TCL_ERROR;
}
return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr);
}
@@ -1684,19 +556,19 @@
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", TCL_AUTO_LENGTH));
+ "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. */
+ 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;
@@ -1706,12 +578,10 @@
int changeover;
int copied = 0;
int status;
int isBce = 0;
- fields.tzName = NULL;
-
/*
* Check params.
*/
if (objc != 3) {
@@ -1778,11 +648,11 @@
*----------------------------------------------------------------------
*/
static int
ClockGetjuliandayfromerayearweekdayObjCmd(
- void *clientData, /* Opaque pointer to literal pool, etc. */
+ void *clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
@@ -1792,12 +662,10 @@
int changeover;
int copied = 0;
int status;
int isBce = 0;
- fields.tzName = NULL;
-
/*
* Check params.
*/
if (objc != 3) {
@@ -1861,65 +729,22 @@
*----------------------------------------------------------------------
*/
static int
ConvertLocalToUTC(
- ClockClientData *dataPtr, /* Literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
- Tcl_Obj *timezoneObj, /* Time zone */
+ Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
- Tcl_Obj *tzdata; /* Time zone data */
- Tcl_Size rowc; /* Number of rows in tzdata */
+ Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
- Tcl_WideInt seconds;
- ClockLastTZOffs * ltzoc = NULL;
-
- /* fast phase-out for shared GMT-object (don't need to convert UTC 2 UTC) */
- if (timezoneObj == dataPtr->literals[LIT_GMT]) {
- fields->seconds = fields->localSeconds;
- fields->tzOffset = 0;
- return TCL_OK;
- }
-
- /*
- * Check cacheable conversion could be used
- * (last-period UTC2Local cache within the same TZ and seconds)
- */
- for (rowc = 0; rowc < 2; rowc++) {
- ltzoc = &dataPtr->lastTZOffsCache[rowc];
- if (timezoneObj != ltzoc->timezoneObj || changeover != ltzoc->changeover) {
- ltzoc = NULL;
- continue;
- }
- seconds = fields->localSeconds - ltzoc->tzOffset;
- if (seconds >= ltzoc->rangesVal[0]
- && seconds < ltzoc->rangesVal[1]) {
- /* the same time zone and offset (UTC time inside the last minute) */
- fields->tzOffset = ltzoc->tzOffset;
- fields->seconds = seconds;
- return TCL_OK;
- }
- /* in the DST-hole (because of the check above) - correct localSeconds */
- if (fields->localSeconds == ltzoc->localSeconds) {
- /* the same time zone and offset (but we'll shift local-time) */
- fields->tzOffset = ltzoc->tzOffset;
- fields->seconds = seconds;
- goto dstHole;
- }
- }
/*
* Unpack the tz data.
*/
- tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
- if (tzdata == NULL) {
- return TCL_ERROR;
- }
-
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
@@ -1926,60 +751,14 @@
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'mktime' to convert the time to local
*/
if (rowc == 0) {
- if (ConvertLocalToUTCUsingC(interp, fields, changeover) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /* we cannot cache (ranges unknown yet) - todo: check later the DST-hole here */
- return TCL_OK;
- } else {
- Tcl_WideInt rangesVal[2];
-
- if (ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv,
- rangesVal) != TCL_OK) {
- return TCL_ERROR;
- }
-
- seconds = fields->seconds;
-
- /* Cache the last conversion */
- if (ltzoc != NULL) { /* slot was found above */
- /* timezoneObj and changeover are the same */
- TclSetObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
- } else {
- /* no TZ in cache - just move second slot down and use the first one */
- ltzoc = &dataPtr->lastTZOffsCache[0];
- TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
- TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
- memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
- TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
- ltzoc->changeover = changeover;
- TclInitObjRef(ltzoc->tzName, fields->tzName); /* may be NULL */
- }
- ltzoc->localSeconds = fields->localSeconds;
- ltzoc->rangesVal[0] = rangesVal[0];
- ltzoc->rangesVal[1] = rangesVal[1];
- ltzoc->tzOffset = fields->tzOffset;
- }
-
- /* check DST-hole: if retrieved seconds is out of range */
- if (ltzoc->rangesVal[0] > seconds || seconds >= ltzoc->rangesVal[1]) {
- dstHole:
-#if 0
- printf("given local-time is outside the time-zone (in DST-hole): "
- "%d - offs %d => %d <= %d < %d\n",
- (int)fields->localSeconds, fields->tzOffset,
- (int)ltzoc->rangesVal[0], (int)seconds, (int)ltzoc->rangesVal[1]);
-#endif
- /* because we don't know real TZ (we're outsize), just invalidate local
- * time (which could be verified in ClockValidDate later) */
- fields->localSeconds = TCL_INV_SECONDS; /* not valid seconds */
- }
- return TCL_OK;
+ return ConvertLocalToUTCUsingC(interp, fields, changeover);
+ } else {
+ return ConvertLocalToUTCUsingTable(interp, fields, rowc, rowv);
+ }
}
/*
*----------------------------------------------------------------------
*
@@ -2000,23 +779,20 @@
static int
ConvertLocalToUTCUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
- int rowc, /* Number of points at which time changes */
- Tcl_Obj *const rowv[], /* Points at which time changes */
- Tcl_WideInt *rangesVal) /* Return bounds for time period */
+ 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;
- struct {
- Tcl_Obj *tzName;
- int tzOffset;
- } have[8];
+ int have[8];
int nHave = 0;
- Tcl_Size i;
+ 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
@@ -2024,40 +800,39 @@
* 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 (1) {
- row = LookupLastTransition(interp, fields->seconds, rowc, rowv,
- rangesVal);
+ 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;
}
- for (i = 0; i < nHave; ++i) {
- if (have[i].tzOffset == fields->tzOffset) {
- goto found;
- }
- }
- if (nHave == 8) {
- Tcl_Panic("loop in ConvertLocalToUTCUsingTable");
- }
- have[nHave].tzName = cellv[3];
- have[nHave++].tzOffset = fields->tzOffset;
- fields->seconds = fields->localSeconds - fields->tzOffset;
- }
-
- found:
- fields->tzOffset = have[i].tzOffset;
- fields->seconds = fields->localSeconds - fields->tzOffset;
- TclSetObjRef(fields->tzName, have[i].tzName);
-
+ 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;
}
/*
*----------------------------------------------------------------------
@@ -2084,18 +859,23 @@
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.
*/
- ClockExtractJDAndSODFromSeconds(fields->julianDay, secondOfDay,
- fields->localSeconds);
-
+ 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'.
@@ -2128,11 +908,11 @@
*/
if (localErrno != 0
|| (fields->seconds == -1 && timeVal.tm_yday == -1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "time value too large/small to represent", TCL_AUTO_LENGTH));
+ "time value too large/small to represent", -1));
return TCL_ERROR;
}
return TCL_OK;
}
@@ -2150,70 +930,24 @@
* Populates the 'tzName' and 'tzOffset' fields.
*
*----------------------------------------------------------------------
*/
-int
+static int
ConvertUTCToLocal(
- ClockClientData *dataPtr, /* Literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the time */
- Tcl_Obj *timezoneObj, /* Time zone */
+ Tcl_Obj *tzdata, /* Time zone data */
int changeover) /* Julian Day of the Gregorian transition */
{
- Tcl_Obj *tzdata; /* Time zone data */
- Tcl_Size rowc; /* Number of rows in tzdata */
+ Tcl_Size rowc; /* Number of rows in tzdata */
Tcl_Obj **rowv; /* Pointers to the rows */
- ClockLastTZOffs * ltzoc = NULL;
-
- /* fast phase-out for shared GMT-object (don't need to convert UTC 2 UTC) */
- if (timezoneObj == dataPtr->literals[LIT_GMT]) {
- fields->localSeconds = fields->seconds;
- fields->tzOffset = 0;
- if (dataPtr->gmtTZName == NULL) {
- Tcl_Obj *tzName;
-
- tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
- if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK
- || Tcl_ListObjIndex(interp, rowv[0], 3, &tzName) != TCL_OK) {
- return TCL_ERROR;
- }
- TclSetObjRef(dataPtr->gmtTZName, tzName);
- }
- TclSetObjRef(fields->tzName, dataPtr->gmtTZName);
- return TCL_OK;
- }
-
- /*
- * Check cacheable conversion could be used
- * (last-period UTC2Local cache within the same TZ and seconds)
- */
- for (rowc = 0; rowc < 2; rowc++) {
- ltzoc = &dataPtr->lastTZOffsCache[rowc];
- if (timezoneObj != ltzoc->timezoneObj || changeover != ltzoc->changeover) {
- ltzoc = NULL;
- continue;
- }
- if (fields->seconds >= ltzoc->rangesVal[0]
- && fields->seconds < ltzoc->rangesVal[1]) {
- /* the same time zone and offset (UTC time inside the last minute) */
- fields->tzOffset = ltzoc->tzOffset;
- fields->localSeconds = fields->seconds + fields->tzOffset;
- TclSetObjRef(fields->tzName, ltzoc->tzName);
- return TCL_OK;
- }
- }
/*
* Unpack the tz data.
*/
- tzdata = ClockGetTZData(dataPtr, interp, timezoneObj);
- if (tzdata == NULL) {
- return TCL_ERROR;
- }
-
if (TclListObjGetElements(interp, tzdata, &rowc, &rowv) != TCL_OK) {
return TCL_ERROR;
}
/*
@@ -2220,50 +954,14 @@
* Special case: If the time zone is :localtime, the tzdata will be empty.
* Use 'localtime' to convert the time to local
*/
if (rowc == 0) {
- if (ConvertUTCToLocalUsingC(interp, fields, changeover) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /* signal we need to revalidate TZ epoch next time fields gets used. */
- fields->flags |= CLF_CTZ;
-
- /* we cannot cache (ranges unknown yet) */
- } else {
- Tcl_WideInt rangesVal[2];
-
- if (ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv,
- rangesVal) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /* converted using table (TZ isn't :localtime) */
- fields->flags &= ~CLF_CTZ;
-
- /* Cache the last conversion */
- if (ltzoc != NULL) { /* slot was found above */
- /* timezoneObj and changeover are the same */
- TclSetObjRef(ltzoc->tzName, fields->tzName);
- } else {
- /* no TZ in cache - just move second slot down and use the first one */
- ltzoc = &dataPtr->lastTZOffsCache[0];
- TclUnsetObjRef(dataPtr->lastTZOffsCache[1].timezoneObj);
- TclUnsetObjRef(dataPtr->lastTZOffsCache[1].tzName);
- memcpy(&dataPtr->lastTZOffsCache[1], ltzoc, sizeof(*ltzoc));
- TclInitObjRef(ltzoc->timezoneObj, timezoneObj);
- ltzoc->changeover = changeover;
- TclInitObjRef(ltzoc->tzName, fields->tzName);
- }
- ltzoc->localSeconds = fields->localSeconds;
- ltzoc->rangesVal[0] = rangesVal[0];
- ltzoc->rangesVal[1] = rangesVal[1];
- ltzoc->tzOffset = fields->tzOffset;
- }
-
- return TCL_OK;
+ return ConvertUTCToLocalUsingC(interp, fields, changeover);
+ } else {
+ return ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv);
+ }
}
/*
*----------------------------------------------------------------------
*
@@ -2284,35 +982,35 @@
static int
ConvertUTCToLocalUsingTable(
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Fields of the date */
- Tcl_Size rowc, /* Number of rows in the conversion table
+ Tcl_Size rowc, /* Number of rows in the conversion table
* (>= 1) */
- Tcl_Obj *const rowv[], /* Rows of the conversion table */
- Tcl_WideInt *rangesVal) /* Return bounds for time period */
+ 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_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, rangesVal);
- if (row == NULL
- || TclListObjGetElements(interp, row, &cellc, &cellv) != TCL_OK
- || TclGetIntFromObj(interp, cellv[1], &fields->tzOffset) != TCL_OK) {
+ 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.
*/
- TclSetObjRef(fields->tzName, cellv[3]);
+ fields->tzName = cellv[3];
+ Tcl_IncrRefCount(fields->tzName);
fields->localSeconds = fields->seconds + fields->tzOffset;
return TCL_OK;
}
/*
@@ -2341,29 +1039,29 @@
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], *p; /* Buffer for time zone name */
+ 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", TCL_AUTO_LENGTH));
+ "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)", TCL_AUTO_LENGTH));
+ "large/small to represent)", -1));
Tcl_SetErrorCode(interp, "CLOCK", "localtimeFailed", (char *)NULL);
return TCL_ERROR;
}
/*
@@ -2378,11 +1076,11 @@
/*
* Convert that value to seconds.
*/
- fields->localSeconds = (((fields->julianDay * 24LL
+ 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.
@@ -2394,18 +1092,19 @@
*buffer = '-';
diff = -diff;
} else {
*buffer = '+';
}
- TclItoAw(buffer + 1, diff / 3600, '0', 2);
+ snprintf(buffer+1, sizeof(buffer) - 1, "%02d", diff / 3600);
diff %= 3600;
- p = TclItoAw(buffer + 3, diff / 60, '0', 2);
+ snprintf(buffer+3, sizeof(buffer) - 3, "%02d", diff / 60);
diff %= 60;
- if (diff != 0) {
- p = TclItoAw(buffer + 5, diff, '0', 2);
+ if (diff > 0) {
+ snprintf(buffer+5, sizeof(buffer) - 5, "%02d", diff);
}
- TclSetObjRef(fields->tzName, Tcl_NewStringObj(buffer, p - buffer));
+ fields->tzName = Tcl_NewStringObj(buffer, -1);
+ Tcl_IncrRefCount(fields->tzName);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -2419,21 +1118,20 @@
* Returns a pointer to the row, or NULL if an error occurs.
*
*----------------------------------------------------------------------
*/
-Tcl_Obj *
+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_WideInt *rangesVal) /* Return bounds for time period */
+ 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, fromVal = LLONG_MIN, toVal = LLONG_MAX;
+ Tcl_WideInt compVal;
/*
* Examine the first row to make sure we're in bounds.
*/
@@ -2445,43 +1143,32 @@
/*
* Bizarre case - first row doesn't begin at MIN_WIDE_INT. Return it
* anyway.
*/
- if (tick < (fromVal = compVal)) {
- if (rangesVal) {
- rangesVal[0] = fromVal;
- rangesVal[1] = toVal;
- }
+ if (tick < compVal) {
return rowv[0];
}
/*
* Binary-search to find the transition.
*/
l = 0;
- u = rowc - 1;
+ 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;
- fromVal = compVal;
} else {
- u = m - 1;
- toVal = compVal;
- }
- }
-
- if (rangesVal) {
- rangesVal[0] = fromVal;
- rangesVal[1] = toVal;
+ u = m-1;
+ }
}
return rowv[l];
}
/*
@@ -2509,12 +1196,10 @@
* transition */
{
TclDateFields temp;
int dayOfFiscalYear;
- temp.tzName = NULL;
-
/*
* 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.
*/
@@ -2700,11 +1385,11 @@
*/
month = (day*12) / dipm[12];
/* then do forwards backwards correction */
while (1) {
if (day > dipm[month]) {
- if (month >= 11 || day <= dipm[month + 1]) {
+ if (month >= 11 || day <= dipm[month+1]) {
break;
}
month++;
} else {
if (month == 0) {
@@ -2712,11 +1397,11 @@
}
month--;
}
}
day -= dipm[month];
- fields->month = month + 1;
+ fields->month = month+1;
fields->dayOfMonth = day;
}
/*
*----------------------------------------------------------------------
@@ -2733,22 +1418,20 @@
* Stores 'julianDay' in the fields.
*
*----------------------------------------------------------------------
*/
-void
+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;
- firstWeek.tzName = NULL;
-
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
firstWeek.isBce = fields->isBce;
@@ -2786,11 +1469,11 @@
* Stores day number in 'julianDay'
*
*----------------------------------------------------------------------
*/
-void
+static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
Tcl_WideInt year, ym1, ym1o4, ym1o100, ym1o400;
@@ -2823,11 +1506,11 @@
*/
fields->gregorian = 1;
if (year < 1) {
fields->isBce = 1;
- fields->year = 1 - year;
+ fields->year = 1-year;
} else {
fields->isBce = 0;
fields->year = year;
}
@@ -2883,64 +1566,10 @@
}
/*
*----------------------------------------------------------------------
*
- * GetJulianDayFromEraYearDay --
- *
- * Given era, year, and dayOfYear (in TclDateFields), and the
- * Gregorian transition date, computes the Julian Day Number.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Stores day number in 'julianDay'
- *
- *----------------------------------------------------------------------
- */
-
-void
-GetJulianDayFromEraYearDay(
- TclDateFields *fields, /* Date to convert */
- int changeover) /* Gregorian transition date as a Julian Day */
-{
- Tcl_WideInt year, ym1;
-
- /* Get absolute year number from the civil year */
- if (fields->isBce) {
- year = 1 - fields->year;
- } else {
- year = fields->year;
- }
-
- ym1 = year - 1;
-
- /* Try the Gregorian calendar first. */
- fields->gregorian = 1;
- fields->julianDay =
- 1721425
- + fields->dayOfYear
- + (365 * ym1)
- + (ym1 / 4)
- - (ym1 / 100)
- + (ym1 / 400);
-
- /* If the date is before the Gregorian change, use the Julian calendar. */
-
- if (fields->julianDay < changeover) {
- fields->gregorian = 0;
- fields->julianDay =
- 1721423
- + fields->dayOfYear
- + (365 * ym1)
- + (ym1 / 4);
- }
-}
-/*
- *----------------------------------------------------------------------
- *
* IsGregorianLeapYear --
*
* Tests whether a given year is a leap year, in either Julian or
* Gregorian calendar.
*
@@ -2948,26 +1577,26 @@
* Returns 1 for a leap year, 0 otherwise.
*
*----------------------------------------------------------------------
*/
-int
+static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
Tcl_WideInt year = fields->year;
if (fields->isBce) {
year = 1 - year;
}
- if (year % 4 != 0) {
+ if (year%4 != 0) {
return 0;
} else if (!(fields->gregorian)) {
return 1;
- } else if (year % 400 == 0) {
+ } else if (year%400 == 0) {
return 1;
- } else if (year % 100 == 0) {
+ } else if (year%100 == 0) {
return 0;
} else {
return 1;
}
}
@@ -3052,12 +1681,11 @@
}
#else
varName = TclGetString(objv[1]);
varValue = getenv(varName);
if (varValue != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- varValue, TCL_AUTO_LENGTH));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(varValue, -1));
}
#endif
return TCL_OK;
}
@@ -3148,18 +1776,18 @@
&index) != TCL_OK) {
return TCL_ERROR;
}
break;
default:
- Tcl_WrongNumArgs(interp, 0, objv, "clock clicks ?-switch?");
+ Tcl_WrongNumArgs(interp, 1, objv, "?-switch?");
return TCL_ERROR;
}
switch (index) {
case CLICKS_MILLIS:
Tcl_GetTime(&now);
- clicks = now.sec * 1000LL + now.usec / 1000;
+ clicks = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000;
break;
case CLICKS_NATIVE:
#ifdef TCL_WIDE_CLICKS
clicks = TclpGetWideClicks();
#else
@@ -3202,11 +1830,11 @@
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
- Tcl_WrongNumArgs(interp, 0, objv, "clock milliseconds");
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)
now.sec * 1000 + now.usec / 1000);
@@ -3238,1277 +1866,135 @@
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
- Tcl_WrongNumArgs(interp, 0, objv, "clock microseconds");
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclpGetMicroseconds()));
return TCL_OK;
}
-
-static inline void
-ClockInitFmtScnArgs(
- ClockClientData *dataPtr,
- Tcl_Interp *interp,
- ClockFmtScnCmdArgs *opts)
-{
- memset(opts, 0, sizeof(*opts));
- opts->dataPtr = dataPtr;
- opts->interp = interp;
-}
/*
*-----------------------------------------------------------------------------
*
- * ClockParseFmtScnArgs --
+ * ClockParseformatargsObjCmd --
*
- * Parses the arguments for sub-commands "scan", "format" and "add".
- *
- * Note: common options table used here, because for the options often used
- * the same literals (objects), so it avoids permanent "recompiling" of
- * option object representation to indexType with another table.
+ * Parses the arguments for [clock format].
*
* Results:
- * Returns a standard Tcl result, and stores parsed options
- * (format, the locale, timezone and base) in structure "opts".
+ * 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.
*
*-----------------------------------------------------------------------------
*/
-typedef enum ClockOperation {
- CLC_OP_FMT = 0, /* Doing [clock format] */
- CLC_OP_SCN, /* Doing [clock scan] */
- CLC_OP_ADD /* Doing [clock add] */
-} ClockOperation;
-
static int
-ClockParseFmtScnArgs(
- ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */
- TclDateFields *date, /* Extracted date-time corresponding base
- * (by scan or add) resp. clockval (by format) */
- Tcl_Size objc, /* Parameter count */
- Tcl_Obj *const objv[], /* Parameter vector */
- ClockOperation operation, /* What operation are we doing: format, scan, add */
- const char *syntax) /* Syntax of the current command */
-{
- Tcl_Interp *interp = opts->interp;
- ClockClientData *dataPtr = opts->dataPtr;
+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[] = {
- "-base", "-format", "-gmt", "-locale", "-timezone", "-validate", NULL
- };
+ static const char *const options[] = { /* Command line options expected */
+ "-format", "-gmt", "-locale",
+ "-timezone", NULL };
enum optionInd {
- CLC_ARGS_BASE, CLC_ARGS_FORMAT, CLC_ARGS_GMT, CLC_ARGS_LOCALE,
- CLC_ARGS_TIMEZONE, CLC_ARGS_VALIDATE
+ 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_Size i, baseIdx;
- Tcl_WideInt baseVal; /* Base time, expressed in seconds from the Epoch */
-
- if (operation == CLC_OP_SCN) {
- /* default flags (from configure) */
- opts->flags |= dataPtr->defFlags & CLF_VALIDATE;
- } else {
- /* clock value (as current base) */
- opts->baseObj = objv[(baseIdx = 1)];
- saw |= 1 << CLC_ARGS_BASE;
+ 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.
*/
- for (i = 2; i < objc; i+=2) {
- /* bypass integers (offsets) by "clock add" */
- if (operation == CLC_OP_ADD) {
- Tcl_WideInt num;
-
- if (TclGetWideIntFromObj(NULL, objv[i], &num) == TCL_OK) {
- continue;
- }
- }
- /* get option */
- if (Tcl_GetIndexFromObj(interp, objv[i], options,
- "option", 0, &optionIndex) != TCL_OK) {
- goto badOptionMsg;
- }
- /* if already specified */
- if (saw & (1 << optionIndex)) {
- if (operation != CLC_OP_SCN && optionIndex == CLC_ARGS_BASE) {
- goto badOptionMsg;
- }
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": doubly present",
- TclGetString(objv[i])));
- goto badOption;
- }
- switch (optionIndex) {
- case CLC_ARGS_FORMAT:
- if (operation == CLC_OP_ADD) {
- goto badOptionMsg;
- }
- opts->formatObj = objv[i + 1];
- break;
- case CLC_ARGS_GMT:
- if (Tcl_GetBooleanFromObj(interp, objv[i + 1], &gmtFlag) != TCL_OK){
- return TCL_ERROR;
- }
- break;
- case CLC_ARGS_LOCALE:
- opts->localeObj = objv[i + 1];
- break;
- case CLC_ARGS_TIMEZONE:
- opts->timezoneObj = objv[i + 1];
- break;
- case CLC_ARGS_BASE:
- opts->baseObj = objv[(baseIdx = i + 1)];
- break;
- case CLC_ARGS_VALIDATE:
- if (operation != CLC_OP_SCN) {
- goto badOptionMsg;
- } else {
- int val;
-
- if (Tcl_GetBooleanFromObj(interp, objv[i + 1], &val) != TCL_OK) {
- return TCL_ERROR;
- }
- if (val) {
- opts->flags |= CLF_VALIDATE;
- } else {
- opts->flags &= ~CLF_VALIDATE;
- }
- }
+ 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 ((saw & (1 << CLC_ARGS_GMT))
- && (saw & (1 << CLC_ARGS_TIMEZONE))) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot use -gmt and -timezone in same call", TCL_AUTO_LENGTH));
+ 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) {
- opts->timezoneObj = dataPtr->literals[LIT_GMT];
- } else if (opts->timezoneObj == NULL
- || TclGetString(opts->timezoneObj) == NULL
- || opts->timezoneObj->length == 0) {
- /* If time zone not specified use system time zone */
- opts->timezoneObj = ClockGetSystemTimeZone(dataPtr, interp);
- if (opts->timezoneObj == NULL) {
- return TCL_ERROR;
- }
- }
-
- /* Setup timezone (normalize object if needed and load TZ on demand) */
-
- opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp, opts->timezoneObj);
- if (opts->timezoneObj == NULL) {
- return TCL_ERROR;
- }
-
- /* Base (by scan or add) or clock value (by format) */
-
- if (opts->baseObj != NULL) {
- Tcl_Obj *baseObj = opts->baseObj;
-
- /* bypass integer recognition if looks like option "-now" */
- if ((baseObj->bytes && baseObj->length == 4 && baseObj->bytes[1] == 'n')
- || TclGetWideIntFromObj(NULL, baseObj, &baseVal) != TCL_OK) {
- /* we accept "-now" as current date-time */
- static const char *const nowOpts[] = {
- "-now", NULL
- };
- int idx;
-
- if (Tcl_GetIndexFromObj(interp, baseObj, nowOpts, "seconds",
- TCL_EXACT, &idx) == TCL_OK) {
- goto baseNow;
- }
-
- if (TclHasInternalRep(baseObj, &tclBignumType)) {
- goto baseOverflow;
- }
-
- Tcl_AppendResult(interp, " or integer", NULL);
- 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, &tclBignumType)
- || baseVal < TCL_MIN_SECONDS || baseVal > TCL_MAX_SECONDS) {
- baseOverflow:
- Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]);
- i = baseIdx;
- goto badOption;
- }
- } else {
- Tcl_Time now;
-
- baseNow:
- Tcl_GetTime(&now);
- baseVal = (Tcl_WideInt) now.sec;
- }
-
- /*
- * Extract year, month and day from the base time for the parser to use as
- * defaults
- */
-
- /* check base fields already cached (by TZ, last-second cache) */
- if (dataPtr->lastBase.timezoneObj == opts->timezoneObj
- && dataPtr->lastBase.date.seconds == baseVal
- && (!(dataPtr->lastBase.date.flags & CLF_CTZ)
- || dataPtr->lastTZEpoch == TzsetIfNecessary())) {
- memcpy(date, &dataPtr->lastBase.date, ClockCacheableDateFieldsSize);
- } else {
- /* extact fields from base */
- date->seconds = baseVal;
- if (ClockGetDateFields(dataPtr, interp, date, opts->timezoneObj,
- GREGORIAN_CHANGE_DATE) != TCL_OK) {
- /* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */
- return TCL_ERROR;
- }
- /* cache last base */
- memcpy(&dataPtr->lastBase.date, date, ClockCacheableDateFieldsSize);
- TclSetObjRef(dataPtr->lastBase.timezoneObj, opts->timezoneObj);
- }
-
- return TCL_OK;
-
- badOptionMsg:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad option \"%s\": must be %s",
- TclGetString(objv[i]), syntax));
-
- badOption:
- Tcl_SetErrorCode(interp, "CLOCK", "badOption",
- (i < objc) ? TclGetString(objv[i]) : (char *)NULL, (char *)NULL);
- return TCL_ERROR;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockFormatObjCmd -- , clock format --
- *
- * This function is invoked to process the Tcl "clock format" command.
- *
- * 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.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockFormatObjCmd(
- void *clientData, /* Client data containing literal pool */
- Tcl_Interp *interp, /* Tcl interpreter */
- int objc, /* Parameter count */
- Tcl_Obj *const objv[]) /* Parameter values */
-{
- ClockClientData *dataPtr = (ClockClientData *)clientData;
- static const char *syntax = "clock format clockval|-now "
- "?-format string? "
- "?-gmt boolean? "
- "?-locale LOCALE? ?-timezone ZONE?";
- int ret;
- ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
- DateFormat dateFmt; /* Common structure used for formatting */
-
- /* even number of arguments */
- if ((objc & 1) == 1) {
- Tcl_WrongNumArgs(interp, 0, objv, syntax);
- Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
- return TCL_ERROR;
- }
-
- memset(&dateFmt, 0, sizeof(dateFmt));
-
- /*
- * Extract values for the keywords.
- */
-
- ClockInitFmtScnArgs(dataPtr, interp, &opts);
- ret = ClockParseFmtScnArgs(&opts, &dateFmt.date, objc, objv,
- CLC_OP_FMT, "-format, -gmt, -locale, or -timezone");
- if (ret != TCL_OK) {
- goto done;
- }
-
- /* Default format */
- if (opts.formatObj == NULL) {
- opts.formatObj = dataPtr->literals[LIT__DEFAULT_FORMAT];
- }
-
- /* Use compiled version of Format - */
- ret = ClockFormat(&dateFmt, &opts);
-
- done:
- TclUnsetObjRef(dateFmt.date.tzName);
- return ret;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockScanObjCmd -- , clock scan --
- *
- * This function is invoked to process the Tcl "clock scan" command.
- *
- * 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.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockScanObjCmd(
- void *clientData, /* Client data containing literal pool */
- Tcl_Interp *interp, /* Tcl interpreter */
- int objc, /* Parameter count */
- Tcl_Obj *const objv[]) /* Parameter values */
-{
- ClockClientData *dataPtr = (ClockClientData *)clientData;
- static const char *syntax = "clock scan string "
- "?-base seconds? "
- "?-format string? "
- "?-gmt boolean? "
- "?-locale LOCALE? ?-timezone ZONE? ?-validate boolean?";
- int ret;
- ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
- DateInfo yy; /* Common structure used for parsing */
- DateInfo *info = &yy;
-
- /* even number of arguments */
- if ((objc & 1) == 1) {
- Tcl_WrongNumArgs(interp, 0, objv, syntax);
- Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
- return TCL_ERROR;
- }
-
- ClockInitDateInfo(&yy);
-
- /*
- * Extract values for the keywords.
- */
-
- ClockInitFmtScnArgs(dataPtr, interp, &opts);
- ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv,
- CLC_OP_SCN, "-base, -format, -gmt, -locale, -timezone or -validate");
- if (ret != TCL_OK) {
- goto done;
- }
-
- /* seconds are in localSeconds (relative base date), so reset time here */
- yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; yyMeridian = MER24;
-
- /* If free scan */
- if (opts.formatObj == NULL) {
- /* Use compiled version of FreeScan - */
-
- /* [SB] TODO: Perhaps someday we'll localize the legacy code. Right now,
- * it's not localized. */
- if (opts.localeObj != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "legacy [clock scan] does not support -locale", TCL_AUTO_LENGTH));
- Tcl_SetErrorCode(interp, "CLOCK", "flagWithLegacyFormat", (char *)NULL);
- ret = TCL_ERROR;
- goto done;
- }
- ret = ClockFreeScan(&yy, objv[1], &opts);
- } else {
- /* Use compiled version of Scan - */
-
- ret = ClockScan(&yy, objv[1], &opts);
- }
-
- if (ret != TCL_OK) {
- goto done;
- }
-
- /*
- * If no GMT and not free-scan (where valid stage 1 is done in-between),
- * validate with stage 1 before local time conversion, otherwise it may
- * adjust date/time tokens to valid values
- */
- if ((opts.flags & CLF_VALIDATE_S1)
- && info->flags & (CLF_ASSEMBLE_SECONDS|CLF_LOCALSEC)) {
- ret = ClockValidDate(&yy, &opts, CLF_VALIDATE_S1);
- if (ret != TCL_OK) {
- goto done;
- }
- }
-
- /* Convert date info structure into UTC seconds */
-
- ret = ClockScanCommit(&yy, &opts);
- if (ret != TCL_OK) {
- goto done;
- }
-
- /* Apply remaining validation rules, if expected */
- if (opts.flags & CLF_VALIDATE) {
- ret = ClockValidDate(&yy, &opts, opts.flags & CLF_VALIDATE);
- if (ret != TCL_OK) {
- goto done;
- }
- }
-
- done:
- TclUnsetObjRef(yy.date.tzName);
- if (ret != TCL_OK) {
- return ret;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(yy.date.seconds));
- return TCL_OK;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockScanCommit --
- *
- * Converts date info structure into UTC seconds.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ClockScanCommit(
- DateInfo *info, /* Clock scan info structure */
- ClockFmtScnCmdArgs *opts) /* Format, locale, timezone and base */
-{
- /* If needed assemble julianDay using year, month, etc. */
- if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
- if (info->flags & CLF_ISO8601WEEK) {
- GetJulianDayFromEraYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
- } else if (!(info->flags & CLF_DAYOFYEAR) /* no day of year */
- || (info->flags & (CLF_DAYOFMONTH|CLF_MONTH)) /* yymmdd over yyddd */
- == (CLF_DAYOFMONTH|CLF_MONTH)) {
- GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
- } else {
- GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
- }
- info->flags |= CLF_ASSEMBLE_SECONDS;
- info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
- }
-
- /* some overflow checks */
- if (info->flags & CLF_JULIANDAY) {
- double curJDN = (double)yydate.julianDay
- + ((double)yySecondOfDay - SECONDS_PER_DAY/2) / SECONDS_PER_DAY;
- if (curJDN > opts->dataPtr->maxJDN) {
- Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
- "requested date too large to represent", TCL_AUTO_LENGTH));
- Tcl_SetErrorCode(opts->interp, "CLOCK", "dateTooLarge", (char *)NULL);
- return TCL_ERROR;
- }
- }
-
- /* Local seconds to UTC (stored in yydate.seconds) */
-
- if (info->flags & CLF_ASSEMBLE_SECONDS) {
- yydate.localSeconds =
- -210866803200LL
- + (SECONDS_PER_DAY * yydate.julianDay)
- + (yySecondOfDay % SECONDS_PER_DAY);
- }
-
- if (info->flags & (CLF_ASSEMBLE_SECONDS | CLF_LOCALSEC)) {
- if (ConvertLocalToUTC(opts->dataPtr, opts->interp, &yydate,
- opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) {
- return TCL_ERROR;
- }
- }
-
- /* Increment UTC seconds with relative time */
-
- yydate.seconds += yyRelSeconds;
- return TCL_OK;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockValidDate --
- *
- * Validate date info structure for wrong data (e. g. out of ranges).
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ClockValidDate(
- DateInfo *info, /* Clock scan info structure */
- ClockFmtScnCmdArgs *opts, /* Scan options */
- int stage) /* Stage to validate (1, 2 or 3 for both) */
-{
- const char *errMsg = "", *errCode = "";
- TclDateFields temp;
- int tempCpyFlg = 0;
- ClockClientData *dataPtr = opts->dataPtr;
-
-#if 0
- printf("yyMonth %d, yyDay %d, yyDayOfYear %d, yyHour %d, yyMinutes %d, yySeconds %d, "
- "yySecondOfDay %d, sec %d, daySec %d, tzOffset %d\n",
- yyMonth, yyDay, yydate.dayOfYear, yyHour, yyMinutes, yySeconds,
- yySecondOfDay, (int)yydate.localSeconds, (int)(yydate.localSeconds % SECONDS_PER_DAY),
- yydate.tzOffset);
-#endif
-
- if (!(stage & CLF_VALIDATE_S1) || !(opts->flags & CLF_VALIDATE_S1)) {
- goto stage_2;
- }
- opts->flags &= ~CLF_VALIDATE_S1; /* stage 1 is done */
-
- /* first year (used later in hath / daysInPriorMonths) */
- if ((info->flags & (CLF_YEAR | CLF_ISO8601YEAR))) {
- if ((info->flags & CLF_ISO8601YEAR)) {
- if (yydate.iso8601Year < dataPtr->validMinYear
- || yydate.iso8601Year > dataPtr->validMaxYear) {
- errMsg = "invalid iso year";
- errCode = "iso year";
- goto error;
- }
- }
- if (info->flags & CLF_YEAR) {
- if (yyYear < dataPtr->validMinYear
- || yyYear > dataPtr->validMaxYear) {
- errMsg = "invalid year";
- errCode = "year";
- goto error;
- }
- } else if ((info->flags & CLF_ISO8601YEAR)) {
- yyYear = yydate.iso8601Year; /* used to recognize leap */
- }
- if ((info->flags & (CLF_ISO8601YEAR | CLF_YEAR))
- == (CLF_ISO8601YEAR | CLF_YEAR)) {
- if (yyYear != yydate.iso8601Year) {
- errMsg = "ambiguous year";
- errCode = "year";
- goto error;
- }
- }
- }
- /* and month (used later in hath) */
- if (info->flags & CLF_MONTH) {
- if (yyMonth < 1 || yyMonth > 12) {
- errMsg = "invalid month";
- errCode = "month";
- goto error;
- }
- }
- /* day of month */
- if (info->flags & (CLF_DAYOFMONTH|CLF_DAYOFWEEK)) {
- if (yyDay < 1 || yyDay > 31) {
- errMsg = "invalid day";
- errCode = "day";
- goto error;
- } else if ((info->flags & CLF_MONTH)) {
- const int *h = hath[IsGregorianLeapYear(&yydate)];
-
- if (yyDay > h[yyMonth - 1]) {
- errMsg = "invalid day";
- goto error;
- }
- }
- }
- if (info->flags & CLF_DAYOFYEAR) {
- if (yydate.dayOfYear < 1
- || yydate.dayOfYear > daysInPriorMonths[IsGregorianLeapYear(&yydate)][12]) {
- errMsg = "invalid day of year";
- errCode = "day of year";
- goto error;
- }
- }
-
- /* mmdd !~ ddd */
- if ((info->flags & (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH))
- == (CLF_DAYOFYEAR|CLF_DAYOFMONTH|CLF_MONTH)) {
- if (!tempCpyFlg) {
- memcpy(&temp, &yydate, sizeof(temp));
- tempCpyFlg = 1;
- }
- GetJulianDayFromEraYearDay(&temp, GREGORIAN_CHANGE_DATE);
- if (temp.julianDay != yydate.julianDay) {
- errMsg = "ambiguous day";
- errCode = "day";
- goto error;
- }
- }
-
- if (info->flags & CLF_TIME) {
- /* hour */
- if (yyHour < 0 || yyHour > ((yyMeridian == MER24) ? 23 : 12)) {
- errMsg = "invalid time (hour)";
- errCode = "hour";
- goto error;
- }
- /* minutes */
- if (yyMinutes < 0 || yyMinutes > 59) {
- errMsg = "invalid time (minutes)";
- errCode = "minutes";
- goto error;
- }
- /* oldscan could return secondOfDay (parsedTime) -1 by invalid time (ex.: 25:00:00) */
- if (yySeconds < 0 || yySeconds > 59 || yySecondOfDay <= -1) {
- errMsg = "invalid time";
- errCode = "seconds";
- goto error;
- }
- }
-
- if (!(stage & CLF_VALIDATE_S2) || !(opts->flags & CLF_VALIDATE_S2)) {
- return TCL_OK;
- }
- opts->flags &= ~CLF_VALIDATE_S2; /* stage 2 is done */
-
- /*
- * Further tests expected ready calculated julianDay (inclusive relative),
- * and time-zone conversion (local to UTC time).
- */
- stage_2:
-
- /* time, regarding the modifications by the time-zone (looks for given time
- * in between DST-time hole, so does not exist in this time-zone) */
- if (info->flags & CLF_TIME) {
- /*
- * we don't need to do the backwards time-conversion (UTC to local) and
- * compare results, because the after conversion (local to UTC) we
- * should have valid localSeconds (was not invalidated to TCL_INV_SECONDS),
- * so if it was invalidated - invalid time, outside the time-zone (in DST-hole)
- */
- if (yydate.localSeconds == TCL_INV_SECONDS) {
- errMsg = "invalid time (does not exist in this time-zone)";
- errCode = "out-of-time";
- goto error;
- }
- }
-
- /* day of week */
- if (info->flags & CLF_DAYOFWEEK) {
- if (!tempCpyFlg) {
- memcpy(&temp, &yydate, sizeof(temp));
- tempCpyFlg = 1;
- }
- GetYearWeekDay(&temp, GREGORIAN_CHANGE_DATE);
- if (temp.dayOfWeek != yyDayOfWeek) {
- errMsg = "invalid day of week";
- errCode = "day of week";
- goto error;
- }
- }
-
- return TCL_OK;
-
- error:
- Tcl_SetObjResult(opts->interp, Tcl_ObjPrintf(
- "unable to convert input string: %s", errMsg));
- Tcl_SetErrorCode(opts->interp, "CLOCK", "invInpStr", errCode, (char *)NULL);
- return TCL_ERROR;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockFreeScan --
- *
- * Used by ClockScanObjCmd for free scanning without format.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockFreeScan(
- DateInfo *info, /* Date fields used for parsing & converting
- * simultaneously a yy-parse structure of the
- * TclClockFreeScan */
- Tcl_Obj *strObj, /* String containing the time to scan */
- ClockFmtScnCmdArgs *opts) /* Command options */
-{
- Tcl_Interp *interp = opts->interp;
- ClockClientData *dataPtr = opts->dataPtr;
- int ret = TCL_ERROR;
-
- /*
- * Parse the date. The parser will fill a structure "info" with date,
- * time, time zone, relative month/day/seconds, relative weekday, ordinal
- * month.
- * Notice that many yy-defines point to values in the "info" or "date"
- * structure, e. g. yySecondOfDay -> info->date.secondOfDay or
- * yyMonth -> info->date.month (same as yydate.month)
- */
- yyInput = TclGetString(strObj);
-
- if (TclClockFreeScan(interp, info) != TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "unable to convert date-time string \"%s\": %s",
- TclGetString(strObj), Tcl_GetString(Tcl_GetObjResult(interp))));
- goto done;
- }
-
- /*
- * If the caller supplied a date in the string, update the date with
- * the value. If the caller didn't specify a time with the date, default to
- * midnight.
- */
-
- if (info->flags & CLF_YEAR) {
- if (yyYear < 100) {
- if (yyYear >= dataPtr->yearOfCenturySwitch) {
- yyYear -= 100;
- }
- yyYear += dataPtr->currentYearCentury;
- }
- yydate.isBce = 0;
- info->flags |= CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS;
- }
-
- /*
- * If the caller supplied a time zone in the string, make it into a time
- * zone indicator of +-hhmm and setup this time zone.
- */
-
- if (info->flags & CLF_ZONE) {
- if (yyTimezone || !yyDSTmode) {
- /* Real time zone from numeric zone */
- Tcl_Obj *tzObjStor = NULL;
- int minEast = -yyTimezone;
- int dstFlag = 1 - yyDSTmode;
-
- tzObjStor = ClockFormatNumericTimeZone(
- 60 * minEast + 3600 * dstFlag);
- Tcl_IncrRefCount(tzObjStor);
-
- opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp, tzObjStor);
-
- Tcl_DecrRefCount(tzObjStor);
- } else {
- /* simplest case - GMT / UTC */
- opts->timezoneObj = ClockSetupTimeZone(dataPtr, interp,
- dataPtr->literals[LIT_GMT]);
- }
- if (opts->timezoneObj == NULL) {
- goto done;
- }
-
- // TclSetObjRef(yydate.tzName, opts->timezoneObj);
-
- info->flags |= CLF_ASSEMBLE_SECONDS;
- }
-
- /*
- * For freescan apply validation rules (stage 1) before mixed with
- * relative time (otherwise always valid recalculated date & time).
- */
- if (opts->flags & CLF_VALIDATE) {
- if (ClockValidDate(info, opts, CLF_VALIDATE_S1) != TCL_OK) {
- goto done;
- }
- }
-
- /*
- * Assemble date, time, zone into seconds-from-epoch
- */
-
- if ((info->flags & (CLF_TIME | CLF_HAVEDATE)) == CLF_HAVEDATE) {
- yySecondOfDay = 0;
- info->flags |= CLF_ASSEMBLE_SECONDS;
- } else if (info->flags & CLF_TIME) {
- yySecondOfDay = ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian);
- info->flags |= CLF_ASSEMBLE_SECONDS;
- } else if ((info->flags & (CLF_DAYOFWEEK | CLF_HAVEDATE)) == CLF_DAYOFWEEK
- || (info->flags & CLF_ORDINALMONTH)
- || ((info->flags & CLF_RELCONV)
- && (yyRelMonth != 0 || yyRelDay != 0))) {
- yySecondOfDay = 0;
- info->flags |= CLF_ASSEMBLE_SECONDS;
- } else {
- yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY;
- }
-
- /*
- * Do relative times
- */
-
- ret = ClockCalcRelTime(info);
-
- /* Free scanning completed - date ready */
-
- done:
- return ret;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockCalcRelTime --
- *
- * Used for calculating of relative times.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-int
-ClockCalcRelTime(
- DateInfo *info) /* Date fields used for converting */
-{
- int prevDayOfWeek = yyDayOfWeek; /* preserve unchanged day of week */
-
- /*
- * Because some calculations require in-between conversion of the
- * julian day, we can repeat this processing multiple times
- */
- repeat_rel:
- if (info->flags & CLF_RELCONV) {
- /*
- * Relative conversion normally possible in UTC time only, because
- * of possible wrong local time increment if ignores in-between DST-hole.
- * (see test-cases clock-34.53, clock-34.54).
- * So increment date in julianDay, but time inside day in UTC (seconds).
- */
-
- /* add months (or years in months) */
-
- if (yyRelMonth != 0) {
- int m, h;
-
- /* if needed extract year, month, etc. again */
- if (info->flags & CLF_ASSEMBLE_DATE) {
- GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
- GetMonthDay(&yydate);
- GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
- info->flags &= ~CLF_ASSEMBLE_DATE;
- }
-
- /* add the requisite number of months */
- yyMonth += yyRelMonth - 1;
- yyYear += yyMonth / 12;
- m = yyMonth % 12;
- /* compiler fix for negative offs - wrap y, m = (0, -1) -> (-1, 11) */
- if (m < 0) {
- yyYear--;
- m = 12 + m;
- }
- yyMonth = m + 1;
-
- /* if the day doesn't exist in the current month, repair it */
- h = hath[IsGregorianLeapYear(&yydate)][m];
- if (yyDay > h) {
- yyDay = h;
- }
-
- /* on demand (lazy) assemble julianDay using new year, month, etc. */
- info->flags |= CLF_ASSEMBLE_JULIANDAY | CLF_ASSEMBLE_SECONDS;
-
- yyRelMonth = 0;
- }
-
- /* add days (or other parts aligned to days) */
- if (yyRelDay) {
- /* assemble julianDay using new year, month, etc. */
- if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
- GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
- info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
- }
- yydate.julianDay += yyRelDay;
-
- /* julianDay was changed, on demand (lazy) extract year, month, etc. again */
- info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS;
- yyRelDay = 0;
- }
-
- /* relative time (seconds), if exceeds current date, do the day conversion and
- * leave rest of the increment in yyRelSeconds to add it hereafter in UTC seconds */
- if (yyRelSeconds) {
- Tcl_WideInt newSecs = yySecondOfDay + yyRelSeconds;
-
- /* if seconds increment outside of current date, increment day */
- if (newSecs / SECONDS_PER_DAY != yySecondOfDay / SECONDS_PER_DAY) {
- yyRelDay += newSecs / SECONDS_PER_DAY;
- yySecondOfDay = 0;
- yyRelSeconds = newSecs % SECONDS_PER_DAY;
-
- goto repeat_rel;
- }
- }
-
- info->flags &= ~CLF_RELCONV;
- }
-
- /*
- * Do relative (ordinal) month
- */
-
- if (info->flags & CLF_ORDINALMONTH) {
- int monthDiff;
-
- /* if needed extract year, month, etc. again */
- if (info->flags & CLF_ASSEMBLE_DATE) {
- GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
- GetMonthDay(&yydate);
- GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE);
- info->flags &= ~CLF_ASSEMBLE_DATE;
- }
-
- if (yyMonthOrdinalIncr > 0) {
- monthDiff = yyMonthOrdinal - yyMonth;
- if (monthDiff <= 0) {
- monthDiff += 12;
- }
- yyMonthOrdinalIncr--;
- } else {
- monthDiff = yyMonth - yyMonthOrdinal;
- if (monthDiff >= 0) {
- monthDiff -= 12;
- }
- yyMonthOrdinalIncr++;
- }
-
- /* process it further via relative times */
- yyYear += yyMonthOrdinalIncr;
- yyRelMonth += monthDiff;
- info->flags &= ~CLF_ORDINALMONTH;
- info->flags |= CLF_RELCONV|CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS;
-
- goto repeat_rel;
- }
-
- /*
- * Do relative weekday
- */
-
- if ((info->flags & (CLF_DAYOFWEEK|CLF_HAVEDATE)) == CLF_DAYOFWEEK) {
- /* restore scanned day of week */
- yyDayOfWeek = prevDayOfWeek;
-
- /* if needed assemble julianDay now */
- if (info->flags & CLF_ASSEMBLE_JULIANDAY) {
- GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE);
- info->flags &= ~CLF_ASSEMBLE_JULIANDAY;
- }
-
- yydate.isBce = 0;
- yydate.julianDay = WeekdayOnOrBefore(yyDayOfWeek, yydate.julianDay + 6)
- + 7 * yyDayOrdinal;
- if (yyDayOrdinal > 0) {
- yydate.julianDay -= 7;
- }
- info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS;
- }
-
- return TCL_OK;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockWeekdaysOffs --
- *
- * Get offset in days for the number of week days corresponding the
- * given day of week (skipping Saturdays and Sundays).
- *
- *
- * Results:
- * Returns a day increment adjusted the given weekdays
- *
- *----------------------------------------------------------------------
- */
-
-static inline int
-ClockWeekdaysOffs(
- int dayOfWeek,
- int offs)
-{
- int weeks, resDayOfWeek;
-
- /* offset in days */
- weeks = offs / 5;
- offs = offs % 5;
- /* compiler fix for negative offs - wrap (0, -1) -> (-1, 4) */
- if (offs < 0) {
- weeks--;
- offs = 5 + offs;
- }
- offs += 7 * weeks;
-
- /* resulting day of week */
- {
- int day = (offs % 7);
-
- /* compiler fix for negative offs - wrap (0, -1) -> (-1, 6) */
- if (day < 0) {
- day = 7 + day;
- }
- resDayOfWeek = dayOfWeek + day;
- }
-
- /* adjust if we start from a weekend */
- if (dayOfWeek > 5) {
- int adj = 5 - dayOfWeek;
-
- offs += adj;
- resDayOfWeek += adj;
- }
-
- /* adjust if we end up on a weekend */
- if (resDayOfWeek > 5) {
- offs += 2;
- }
-
- return offs;
-}
-
-/*----------------------------------------------------------------------
- *
- * ClockAddObjCmd -- , clock add --
- *
- * Adds an offset to a given time.
- *
- * Refer to the user documentation to see what it exactly does.
- *
- * 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
- * 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 a standard Tcl result with 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.
- *
- *----------------------------------------------------------------------
- */
-
-int
-ClockAddObjCmd(
- void *clientData, /* Client data containing literal pool */
- Tcl_Interp *interp, /* Tcl interpreter */
- int objc, /* Parameter count */
- Tcl_Obj *const objv[]) /* Parameter values */
-{
- static const char *syntax = "clock add clockval|-now ?number units?..."
- "?-gmt boolean? "
- "?-locale LOCALE? ?-timezone ZONE?";
- ClockClientData *dataPtr = (ClockClientData *)clientData;
- int ret;
- ClockFmtScnCmdArgs opts; /* Format, locale, timezone and base */
- DateInfo yy; /* Common structure used for parsing */
- DateInfo *info = &yy;
-
- /* add "week" to units also (because otherwise ambiguous) */
- static const char *const units[] = {
- "years", "months", "week", "weeks",
- "days", "weekdays",
- "hours", "minutes", "seconds",
- NULL
- };
- enum unitInd {
- CLC_ADD_YEARS, CLC_ADD_MONTHS, CLC_ADD_WEEK, CLC_ADD_WEEKS,
- CLC_ADD_DAYS, CLC_ADD_WEEKDAYS,
- CLC_ADD_HOURS, CLC_ADD_MINUTES, CLC_ADD_SECONDS
- };
- int unitIndex; /* Index of an option. */
- Tcl_Size i;
- Tcl_WideInt offs;
-
- /* even number of arguments */
- if ((objc & 1) == 1) {
- Tcl_WrongNumArgs(interp, 0, objv, syntax);
- Tcl_SetErrorCode(interp, "CLOCK", "wrongNumArgs", (char *)NULL);
- return TCL_ERROR;
- }
-
- ClockInitDateInfo(&yy);
-
- /*
- * Extract values for the keywords.
- */
-
- ClockInitFmtScnArgs(dataPtr, interp, &opts);
- ret = ClockParseFmtScnArgs(&opts, &yy.date, objc, objv,
- CLC_OP_ADD, "-gmt, -locale, or -timezone");
- if (ret != TCL_OK) {
- goto done;
- }
-
- /* time together as seconds of the day */
- yySecondOfDay = yySeconds = yydate.localSeconds % SECONDS_PER_DAY;
- /* seconds are in localSeconds (relative base date), so reset time here */
- yyHour = 0;
- yyMinutes = 0;
- yyMeridian = MER24;
-
- ret = TCL_ERROR;
-
- /*
- * Find each offset and process date increment
- */
-
- for (i = 2; i < objc; i+=2) {
- /* bypass not integers (options, allready processed above in ClockParseFmtScnArgs) */
- if (TclGetWideIntFromObj(NULL, objv[i], &offs) != TCL_OK) {
- continue;
- }
- /* get unit */
- if (Tcl_GetIndexFromObj(interp, objv[i + 1], units, "unit", 0,
- &unitIndex) != TCL_OK) {
- goto done;
- }
- if (TclHasInternalRep(objv[i], &tclBignumType)
- || 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 */
- if (!offs) {
- continue;
- }
-
- /* if in-between conversion needed (already have relative date/time),
- * correct date info, because the date may be changed,
- * so refresh it now */
-
- if ((info->flags & CLF_RELCONV)
- && (unitIndex == CLC_ADD_WEEKDAYS
- /* some months can be shorter as another */
- || yyRelMonth || yyRelDay
- /* day changed */
- || yySeconds + yyRelSeconds > SECONDS_PER_DAY
- || yySeconds + yyRelSeconds < 0)) {
- if (ClockCalcRelTime(info) != TCL_OK) {
- goto done;
- }
- }
-
- /* process increment by offset + unit */
- info->flags |= CLF_RELCONV;
- switch (unitIndex) {
- case CLC_ADD_YEARS:
- yyRelMonth += offs * 12;
- break;
- case CLC_ADD_MONTHS:
- yyRelMonth += offs;
- break;
- case CLC_ADD_WEEK:
- case CLC_ADD_WEEKS:
- yyRelDay += offs * 7;
- break;
- case CLC_ADD_DAYS:
- yyRelDay += offs;
- break;
- case CLC_ADD_WEEKDAYS:
- /* add number of week days (skipping Saturdays and Sundays)
- * to a relative days value. */
- offs = ClockWeekdaysOffs(yy.date.dayOfWeek, offs);
- yyRelDay += offs;
- break;
- case CLC_ADD_HOURS:
- yyRelSeconds += offs * 60 * 60;
- break;
- case CLC_ADD_MINUTES:
- yyRelSeconds += offs * 60;
- break;
- case CLC_ADD_SECONDS:
- yyRelSeconds += offs;
- break;
- }
- }
-
- /*
- * Do relative times (if not yet already processed interim):
- */
-
- if (info->flags & CLF_RELCONV) {
- if (ClockCalcRelTime(info) != TCL_OK) {
- goto done;
- }
- }
-
- /* Convert date info structure into UTC seconds */
-
- ret = ClockScanCommit(&yy, &opts);
-
- done:
- TclUnsetObjRef(yy.date.tzName);
- if (ret != TCL_OK) {
- return ret;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(yy.date.seconds));
- return TCL_OK;
-}
+ 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 -
*
@@ -4535,11 +2021,11 @@
{
Tcl_Time now;
Tcl_Obj *timeObj;
if (objc != 1) {
- Tcl_WrongNumArgs(interp, 0, objv, "clock seconds");
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetTime(&now);
TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec);
@@ -4548,88 +2034,17 @@
}
/*
*----------------------------------------------------------------------
*
- * ClockSafeCatchCmd --
- *
- * Same as "::catch" command but avoids overwriting of interp state.
- *
- * See [554117edde] for more info (and proper solution).
- *
- *----------------------------------------------------------------------
- */
-int
-ClockSafeCatchCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- typedef struct {
- int status; /* return code status */
- int flags; /* Each remaining field saves the */
- int returnLevel; /* corresponding field of the Interp */
- int returnCode; /* struct. These fields taken together are */
- Tcl_Obj *errorInfo; /* the "state" of the interp. */
- Tcl_Obj *errorCode;
- Tcl_Obj *returnOpts;
- Tcl_Obj *objResult;
- Tcl_Obj *errorStack;
- int resetErrorStack;
- } InterpState;
-
- Interp *iPtr = (Interp *)interp;
- int ret, flags = 0;
- InterpState *statePtr;
-
- if (objc == 1) {
- /* wrong # args : */
- return Tcl_CatchObjCmd(NULL, interp, objc, objv);
- }
-
- statePtr = (InterpState *)Tcl_SaveInterpState(interp, 0);
- if (!statePtr->errorInfo) {
- /* todo: avoid traced get of errorInfo here */
- TclInitObjRef(statePtr->errorInfo,
- Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, 0));
- flags |= ERR_LEGACY_COPY;
- }
- if (!statePtr->errorCode) {
- /* todo: avoid traced get of errorCode here */
- TclInitObjRef(statePtr->errorCode,
- Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, 0));
- flags |= ERR_LEGACY_COPY;
- }
-
- /* original catch */
- ret = Tcl_CatchObjCmd(NULL, interp, objc, objv);
-
- if (ret == TCL_ERROR) {
- Tcl_DiscardInterpState((Tcl_InterpState)statePtr);
- return TCL_ERROR;
- }
- /* overwrite result in state with catch result */
- TclSetObjRef(statePtr->objResult, Tcl_GetObjResult(interp));
- /* set result (together with restore state) to interpreter */
- (void) Tcl_RestoreInterpState(interp, (Tcl_InterpState)statePtr);
- /* todo: unless ERR_LEGACY_COPY not set in restore (branch [bug-554117edde] not merged yet) */
- iPtr->flags |= (flags & ERR_LEGACY_COPY);
- return ret;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TzsetIfNecessary --
*
* Calls the tzset() library function if the contents of the TZ
* environment variable has changed.
*
* Results:
- * An epoch counter to allow efficient checking if the timezone has
- * changed.
+ * None.
*
* Side effects:
* Calls tzset.
*
*----------------------------------------------------------------------
@@ -4641,94 +2056,87 @@
#define WCHAR char
#define wcslen strlen
#define wcscmp strcmp
#define wcscpy strcpy
#endif
-#define TZ_INIT_MARKER ((WCHAR *) INT2PTR(-1))
-
-typedef struct ClockTzStatic {
- WCHAR *was; /* Previous value of TZ. */
-#if TCL_MAJOR_VERSION > 8
- long long lastRefresh; /* Used for latency before next refresh. */
-#else
- long lastRefresh; /* Used for latency before next refresh. */
-#endif
- size_t epoch; /* Epoch, signals that TZ changed. */
- size_t envEpoch; /* Last env epoch, for faster signaling,
- * that TZ changed via TCL */
-} ClockTzStatic;
-static ClockTzStatic tz = { /* Global timezone info; protected by
- * clockMutex.*/
- TZ_INIT_MARKER, 0, 0, 0
-};
-
-static size_t
+
+static void
TzsetIfNecessary(void)
{
- const WCHAR *tzNow; /* Current value of TZ. */
- Tcl_Time now; /* Current time. */
- size_t epoch; /* The tz.epoch that the TZ was read at. */
+ 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_GetTime(&now);
- if (now.sec == tz.lastRefresh && tz.envEpoch == TclEnvEpoch) {
- return tz.epoch;
- }
-
- tz.envEpoch = TclEnvEpoch;
- tz.lastRefresh = now.sec;
-
- /* check in lock */
- Tcl_MutexLock(&clockMutex);
- tzNow = getenv("TCL_TZ");
- if (tzNow == NULL) {
- tzNow = getenv("TZ");
- }
- if (tzNow != NULL && (tz.was == NULL || tz.was == TZ_INIT_MARKER
- || wcscmp(tzNow, tz.was) != 0)) {
- tzset();
- if (tz.was != NULL && tz.was != TZ_INIT_MARKER) {
- Tcl_Free(tz.was);
- }
- tz.was = (WCHAR *)Tcl_Alloc(sizeof(WCHAR) * (wcslen(tzNow) + 1));
- wcscpy(tz.was, tzNow);
- epoch = ++tz.epoch;
- } else if (tzNow == NULL && tz.was != NULL) {
- tzset();
- if (tz.was != TZ_INIT_MARKER) {
- Tcl_Free(tz.was);
- }
- tz.was = NULL;
- epoch = ++tz.epoch;
- } else {
- epoch = tz.epoch;
+ 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);
-
- return epoch;
-}
-
-static void
-ClockFinalize(
- TCL_UNUSED(void *))
-{
- ClockFrmScnFinalize();
-
- if (tz.was && tz.was != TZ_INIT_MARKER) {
- Tcl_Free(tz.was);
- }
-
- Tcl_MutexFinalize(&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:
*/
DELETED generic/tclClockFmt.c
Index: generic/tclClockFmt.c
==================================================================
--- generic/tclClockFmt.c
+++ /dev/null
@@ -1,3595 +0,0 @@
-/*
- * 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
- */
-
-static void ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static void ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr);
-static int ClockFmtObj_SetFromAny(Tcl_Interp *, Tcl_Obj *objPtr);
-static void ClockFmtObj_UpdateString(Tcl_Obj *objPtr);
-
-TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */
-
-static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss);
-
-#ifndef TCL_CLOCK_FULL_COMPAT
-#define TCL_CLOCK_FULL_COMPAT 1
-#endif
-
-/*
- * Derivation of tclStringHashKeyType with another allocEntryProc
- */
-
-static Tcl_HashKeyType ClockFmtScnStorageHashKeyType;
-
-#define IntFieldAt(info, offset) \
- ((int *) (((char *) (info)) + (offset)))
-#define WideFieldAt(info, offset) \
- ((Tcl_WideInt *) (((char *) (info)) + (offset)))
-
-/*
- * Clock scan and format facilities.
- */
-
-/*
- *----------------------------------------------------------------------
- *
- * Clock_str2int, Clock_str2wideInt --
- *
- * Fast inline-convertion of string to signed int or wide int by given
- * start/end.
- *
- * The given string should contain numbers chars only (because already
- * pre-validated within parsing routines)
- *
- * Results:
- * Returns a standard Tcl result.
- * TCL_OK - by successful conversion, TCL_ERROR by (wide) int overflow
- *
- *----------------------------------------------------------------------
- */
-
-static inline void
-Clock_str2int_no(
- int *out,
- const char *p,
- const char *e,
- int sign)
-{
- /* assert(e <= p + 10); */
- int val = 0;
-
- /* overflow impossible for 10 digits ("9..9"), so no needs to check at all */
- while (p < e) { /* never overflows */
- val = val * 10 + (*p++ - '0');
- }
- if (sign < 0) {
- val = -val;
- }
- *out = val;
-}
-
-static inline void
-Clock_str2wideInt_no(
- Tcl_WideInt *out,
- const char *p,
- const char *e,
- int sign)
-{
- /* assert(e <= p + 18); */
- Tcl_WideInt val = 0;
-
- /* overflow impossible for 18 digits ("9..9"), so no needs to check at all */
- while (p < e) { /* never overflows */
- val = val * 10 + (*p++ - '0');
- }
- if (sign < 0) {
- val = -val;
- }
- *out = val;
-}
-
-/* int & Tcl_WideInt overflows may happens here (expected case) */
-#if defined(__GNUC__) || defined(__GNUG__)
-# pragma GCC optimize("no-trapv")
-#endif
-
-static inline int
-Clock_str2int(
- int *out,
- const char *p,
- const char *e,
- int sign)
-{
- int val = 0;
- /* overflow impossible for 10 digits ("9..9"), so no needs to check before */
- const char *eNO = p + 10;
-
- if (eNO > e) {
- eNO = e;
- }
- while (p < eNO) { /* never overflows */
- val = val * 10 + (*p++ - '0');
- }
- if (sign >= 0) {
- while (p < e) { /* check for overflow */
- int prev = val;
-
- val = val * 10 + (*p++ - '0');
- if (val / 10 < prev) {
- return TCL_ERROR;
- }
- }
- } else {
- val = -val;
- while (p < e) { /* check for overflow */
- int prev = val;
-
- val = val * 10 - (*p++ - '0');
- if (val / 10 > prev) {
- return TCL_ERROR;
- }
- }
- }
- *out = val;
- return TCL_OK;
-}
-
-static inline int
-Clock_str2wideInt(
- Tcl_WideInt *out,
- const char *p,
- const char *e,
- int sign)
-{
- Tcl_WideInt val = 0;
- /* overflow impossible for 18 digits ("9..9"), so no needs to check before */
- const char *eNO = p + 18;
-
- if (eNO > e) {
- eNO = e;
- }
- while (p < eNO) { /* never overflows */
- val = val * 10 + (*p++ - '0');
- }
- if (sign >= 0) {
- while (p < e) { /* check for overflow */
- Tcl_WideInt prev = val;
-
- val = val * 10 + (*p++ - '0');
- if (val / 10 < prev) {
- return TCL_ERROR;
- }
- }
- } else {
- val = -val;
- while (p < e) { /* check for overflow */
- Tcl_WideInt prev = val;
-
- val = val * 10 - (*p++ - '0');
- if (val / 10 > prev) {
- return TCL_ERROR;
- }
- }
- }
- *out = val;
- return TCL_OK;
-}
-
-int
-TclAtoWIe(
- Tcl_WideInt *out,
- const char *p,
- const char *e,
- int sign)
-{
- return Clock_str2wideInt(out, p, e, sign);
-}
-
-#if defined(__GNUC__) || defined(__GNUG__)
-# pragma GCC reset_options
-#endif
-
-/*
- *----------------------------------------------------------------------
- *
- * Clock_itoaw, Clock_witoaw --
- *
- * Fast inline-convertion of signed int or wide int to string, using
- * given padding with specified padchar and width (or without padding).
- *
- * This is a very fast replacement for sprintf("%02d").
- *
- * Results:
- * Returns position in buffer after end of conversion result.
- *
- *----------------------------------------------------------------------
- */
-
-static inline char *
-Clock_itoaw(
- char *buf,
- int val,
- char padchar,
- unsigned short width)
-{
- char *p;
- static const int wrange[] = {
- 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000
- };
-
- /* positive integer */
-
- if (val >= 0) {
- /* check resp. recalculate width */
- while (width <= 9 && val >= wrange[width]) {
- width++;
- }
- /* number to string backwards */
- p = buf + width;
- *p-- = '\0';
- do {
- char c = val % 10;
-
- val /= 10;
- *p-- = '0' + c;
- } while (val > 0);
- /* fulling with pad-char */
- while (p >= buf) {
- *p-- = padchar;
- }
-
- return buf + width;
- }
- /* negative integer */
-
- if (!width) {
- width++;
- }
- /* check resp. recalculate width (regarding sign) */
- width--;
- while (width <= 9 && val <= -wrange[width]) {
- width++;
- }
- width++;
- /* number to string backwards */
- p = buf + width;
- *p-- = '\0';
- /* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */
- if (-1 % 10 == -1) {
- do {
- char c = val % 10;
-
- val /= 10;
- *p-- = '0' - c;
- } while (val < 0);
- } else {
- do {
- char c = val % 10;
-
- val /= 10;
- *p-- = '0' + c;
- } while (val < 0);
- }
- /* sign by 0 padding */
- if (padchar != '0') {
- *p-- = '-';
- }
- /* fulling with pad-char */
- while (p >= buf + 1) {
- *p-- = padchar;
- }
- /* sign by non 0 padding */
- if (padchar == '0') {
- *p = '-';
- }
-
- return buf + width;
-}
-char *
-TclItoAw(
- char *buf,
- int val,
- char padchar,
- unsigned short width)
-{
- return Clock_itoaw(buf, val, padchar, width);
-}
-
-static inline char *
-Clock_witoaw(
- char *buf,
- Tcl_WideInt val,
- char padchar,
- unsigned short width)
-{
- char *p;
- static const int wrange[] = {
- 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000
- };
-
- /* positive integer */
-
- if (val >= 0) {
- /* check resp. recalculate width */
- if (val >= 10000000000LL) {
- Tcl_WideInt val2 = val / 10000000000LL;
-
- while (width <= 9 && val2 >= wrange[width]) {
- width++;
- }
- width += 10;
- } else {
- while (width <= 9 && val >= wrange[width]) {
- width++;
- }
- }
- /* number to string backwards */
- p = buf + width;
- *p-- = '\0';
- do {
- char c = (val % 10);
- val /= 10;
- *p-- = '0' + c;
- } while (val > 0);
- /* fulling with pad-char */
- while (p >= buf) {
- *p-- = padchar;
- }
-
- return buf + width;
- }
-
- /* negative integer */
-
- if (!width) {
- width++;
- }
- /* check resp. recalculate width (regarding sign) */
- width--;
- if (val <= -10000000000LL) {
- Tcl_WideInt val2 = val / 10000000000LL;
-
- while (width <= 9 && val2 <= -wrange[width]) {
- width++;
- }
- width += 10;
- } else {
- while (width <= 9 && val <= -wrange[width]) {
- width++;
- }
- }
- width++;
- /* number to string backwards */
- p = buf + width;
- *p-- = '\0';
- /* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */
- if (-1 % 10 == -1) {
- do {
- char c = val % 10;
-
- val /= 10;
- *p-- = '0' - c;
- } while (val < 0);
- } else {
- do {
- char c = val % 10;
-
- val /= 10;
- *p-- = '0' + c;
- } while (val < 0);
- }
- /* sign by 0 padding */
- if (padchar != '0') {
- *p-- = '-';
- }
- /* fulling with pad-char */
- while (p >= buf + 1) {
- *p-- = padchar;
- }
- /* sign by non 0 padding */
- if (padchar == '0') {
- *p = '-';
- }
-
- return buf + width;
-}
-
-/*
- * Global GC as LIFO for released scan/format object storages.
- *
- * Used to holds last released CLOCK_FMT_SCN_STORAGE_GC_SIZE formats
- * (after last reference from Tcl-object will be removed). This is helpful
- * to avoid continuous (re)creation and compiling by some dynamically resp.
- * variable format objects, that could be often reused.
- *
- * As long as format storage is used resp. belongs to GC, it takes place in
- * FmtScnHashTable also.
- */
-
-#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
-
-static struct ClockFmtScnStorage_GC {
- ClockFmtScnStorage *stackPtr;
- ClockFmtScnStorage *stackBound;
- unsigned count;
-} ClockFmtScnStorage_GC = {NULL, NULL, 0};
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFmtScnStorageGC_In --
- *
- * Adds an format storage object to GC.
- *
- * If current GC is full (size larger as CLOCK_FMT_SCN_STORAGE_GC_SIZE)
- * this removes last unused storage at begin of GC stack (LIFO).
- *
- * Assumes caller holds the ClockFmtMutex.
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static inline void
-ClockFmtScnStorageGC_In(
- ClockFmtScnStorage *entry)
-{
- /* add new entry */
- TclSpliceIn(entry, ClockFmtScnStorage_GC.stackPtr);
- if (ClockFmtScnStorage_GC.stackBound == NULL) {
- ClockFmtScnStorage_GC.stackBound = entry;
- }
- ClockFmtScnStorage_GC.count++;
-
- /* if GC ist full */
- if (ClockFmtScnStorage_GC.count > CLOCK_FMT_SCN_STORAGE_GC_SIZE) {
- /* GC stack is LIFO: delete first inserted entry */
- ClockFmtScnStorage *delEnt = ClockFmtScnStorage_GC.stackBound;
-
- ClockFmtScnStorage_GC.stackBound = delEnt->prevPtr;
- TclSpliceOut(delEnt, ClockFmtScnStorage_GC.stackPtr);
- ClockFmtScnStorage_GC.count--;
- delEnt->prevPtr = delEnt->nextPtr = NULL;
- /* remove it now */
- ClockFmtScnStorageDelete(delEnt);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFmtScnStorage_GC_Out --
- *
- * Restores (for reusing) given format storage object from GC.
- *
- * Assumes caller holds the ClockFmtMutex.
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static inline void
-ClockFmtScnStorage_GC_Out(
- ClockFmtScnStorage *entry)
-{
- TclSpliceOut(entry, ClockFmtScnStorage_GC.stackPtr);
- ClockFmtScnStorage_GC.count--;
- if (ClockFmtScnStorage_GC.stackBound == entry) {
- ClockFmtScnStorage_GC.stackBound = entry->prevPtr;
- }
- entry->prevPtr = entry->nextPtr = NULL;
-}
-#endif
-
-/*
- * Global format storage hash table of type ClockFmtScnStorageHashKeyType
- * (contains list of scan/format object storages, shared across all threads).
- *
- * Used for fast searching by format string.
- */
-static Tcl_HashTable FmtScnHashTable;
-static int initialized = 0;
-
-/*
- * Wrappers between pointers to hash entry and format storage object
- */
-static inline Tcl_HashEntry *
-HashEntry4FmtScn(
- ClockFmtScnStorage *fss)
-{
- return (Tcl_HashEntry*)(fss + 1);
-}
-
-static inline ClockFmtScnStorage *
-FmtScn4HashEntry(
- Tcl_HashEntry *hKeyPtr)
-{
- return (ClockFmtScnStorage*)(((char*)hKeyPtr) - sizeof(ClockFmtScnStorage));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFmtScnStorageAllocProc --
- *
- * Allocate space for a hash entry containing format storage together
- * with the string key.
- *
- * Results:
- * The return value is a pointer to the created entry.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_HashEntry *
-ClockFmtScnStorageAllocProc(
- TCL_UNUSED(Tcl_HashTable *), /* Hash table. */
- void *keyPtr) /* Key to store in the hash table entry. */
-{
- ClockFmtScnStorage *fss;
- const char *string = (const char *) keyPtr;
- Tcl_HashEntry *hPtr;
- unsigned size = strlen(string) + 1;
- unsigned allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry);
-
- allocsize += size;
- if (size > sizeof(hPtr->key)) {
- allocsize -= sizeof(hPtr->key);
- }
-
- fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize);
-
- /* initialize */
- memset(fss, 0, sizeof(*fss));
-
- hPtr = HashEntry4FmtScn(fss);
- memcpy(&hPtr->key.string, string, size);
- hPtr->clientData = 0; /* currently unused */
-
- return hPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFmtScnStorageFreeProc --
- *
- * Free format storage object and space of given hash entry.
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ClockFmtScnStorageFreeProc(
- Tcl_HashEntry *hPtr)
-{
- ClockFmtScnStorage *fss = FmtScn4HashEntry(hPtr);
-
- if (fss->scnTok != NULL) {
- Tcl_Free(fss->scnTok);
- fss->scnTok = NULL;
- fss->scnTokC = 0;
- }
- if (fss->fmtTok != NULL) {
- Tcl_Free(fss->fmtTok);
- fss->fmtTok = NULL;
- fss->fmtTokC = 0;
- }
-
- Tcl_Free(fss);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFmtScnStorageDelete --
- *
- * Delete format storage object.
- *
- * Results:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ClockFmtScnStorageDelete(
- ClockFmtScnStorage *fss)
-{
- Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss);
- /*
- * This will delete a hash entry and call "Tcl_Free" for storage self, if
- * some additionally handling required, freeEntryProc can be used instead
- */
- Tcl_DeleteHashEntry(hPtr);
-}
-
-/*
- * Type definition of clock-format tcl object type.
- */
-
-static const Tcl_ObjType ClockFmtObjType = {
- "clock-format", /* name */
- ClockFmtObj_FreeInternalRep, /* freeIntRepProc */
- ClockFmtObj_DupInternalRep, /* dupIntRepProc */
- ClockFmtObj_UpdateString, /* updateStringProc */
- ClockFmtObj_SetFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
-};
-
-#define ObjClockFmtScn(objPtr) \
- (*((ClockFmtScnStorage **)&(objPtr)->internalRep.twoPtrValue.ptr1))
-
-#define ObjLocFmtKey(objPtr) \
- (*((Tcl_Obj **)&(objPtr)->internalRep.twoPtrValue.ptr2))
-
-static void
-ClockFmtObj_DupInternalRep(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
-{
- ClockFmtScnStorage *fss = ObjClockFmtScn(srcPtr);
-
- if (fss != NULL) {
- Tcl_MutexLock(&ClockFmtMutex);
- fss->objRefCount++;
- Tcl_MutexUnlock(&ClockFmtMutex);
- }
-
- ObjClockFmtScn(copyPtr) = fss;
- /* regards special case - format not localizable */
- if (ObjLocFmtKey(srcPtr) != srcPtr) {
- TclInitObjRef(ObjLocFmtKey(copyPtr), ObjLocFmtKey(srcPtr));
- } else {
- ObjLocFmtKey(copyPtr) = copyPtr;
- }
- copyPtr->typePtr = &ClockFmtObjType;
-
- /* if no format representation, dup string representation */
- if (fss == NULL) {
- copyPtr->bytes = (char *)Tcl_Alloc(srcPtr->length + 1);
- memcpy(copyPtr->bytes, srcPtr->bytes, srcPtr->length + 1);
- copyPtr->length = srcPtr->length;
- }
-}
-
-static void
-ClockFmtObj_FreeInternalRep(
- Tcl_Obj *objPtr)
-{
- ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr);
- if (fss != NULL && initialized) {
- Tcl_MutexLock(&ClockFmtMutex);
- /* decrement object reference count of format/scan storage */
- if (--fss->objRefCount <= 0) {
-#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
- /* don't remove it right now (may be reusable), just add to GC */
- ClockFmtScnStorageGC_In(fss);
-#else
- /* remove storage (format representation) */
- ClockFmtScnStorageDelete(fss);
-#endif
- }
- Tcl_MutexUnlock(&ClockFmtMutex);
- }
- ObjClockFmtScn(objPtr) = NULL;
- if (ObjLocFmtKey(objPtr) != objPtr) {
- TclUnsetObjRef(ObjLocFmtKey(objPtr));
- } else {
- ObjLocFmtKey(objPtr) = NULL;
- }
- objPtr->typePtr = NULL;
-}
-
-static int
-ClockFmtObj_SetFromAny(
- TCL_UNUSED(Tcl_Interp *),
- Tcl_Obj *objPtr)
-{
- /* validate string representation before free old internal representation */
- (void)TclGetString(objPtr);
-
- /* free old internal representation */
- TclFreeInternalRep(objPtr);
-
- /* initial state of format object */
- ObjClockFmtScn(objPtr) = NULL;
- ObjLocFmtKey(objPtr) = NULL;
- objPtr->typePtr = &ClockFmtObjType;
-
- return TCL_OK;
-}
-
-static void
-ClockFmtObj_UpdateString(
- Tcl_Obj *objPtr)
-{
- const char *name = "UNKNOWN";
- size_t len;
- ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr);
-
- if (fss != NULL) {
- Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss);
- name = hPtr->key.string;
- }
- len = strlen(name);
- objPtr->length = len++,
- objPtr->bytes = (char *)Tcl_AttemptAlloc(len);
- if (objPtr->bytes) {
- memcpy(objPtr->bytes, name, len);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockFrmObjGetLocFmtKey --
- *
- * Retrieves format key object used to search localized format.
- *
- * This is normally stored in second pointer of internal representation.
- * If format object is not localizable, it is equal the given format
- * pointer (special case to fast fallback by not-localizable formats).
- *
- * Results:
- * Returns tcl object with key or format object if not localizable.
- *
- * Side effects:
- * Converts given format object to ClockFmtObjType on demand for caching
- * the key inside its internal representation.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj*
-ClockFrmObjGetLocFmtKey(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- Tcl_Obj *keyObj;
-
- if (objPtr->typePtr != &ClockFmtObjType) {
- if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) {
- return NULL;
- }
- }
-
- keyObj = ObjLocFmtKey(objPtr);
- if (keyObj) {
- return keyObj;
- }
-
- keyObj = Tcl_ObjPrintf("FMT_%s", TclGetString(objPtr));
- TclInitObjRef(ObjLocFmtKey(objPtr), keyObj);
-
- return keyObj;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FindOrCreateFmtScnStorage --
- *
- * Retrieves format storage for given string format.
- *
- * This will find the given format in the global storage hash table
- * or create a format storage object on demaind and save the
- * reference in the first pointer of internal representation of given
- * object.
- *
- * Results:
- * Returns scan/format storage pointer to ClockFmtScnStorage.
- *
- * Side effects:
- * Converts given format object to ClockFmtObjType on demand for caching
- * the format storage reference inside its internal representation.
- * Increments objRefCount of the ClockFmtScnStorage reference.
- *
- *----------------------------------------------------------------------
- */
-
-static ClockFmtScnStorage *
-FindOrCreateFmtScnStorage(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- const char *strFmt = TclGetString(objPtr);
- ClockFmtScnStorage *fss = NULL;
- int isNew;
- Tcl_HashEntry *hPtr;
-
- Tcl_MutexLock(&ClockFmtMutex);
-
- /* if not yet initialized */
- if (!initialized) {
- /* initialize type */
- memcpy(&ClockFmtScnStorageHashKeyType, &tclStringHashKeyType, sizeof(tclStringHashKeyType));
- ClockFmtScnStorageHashKeyType.allocEntryProc = ClockFmtScnStorageAllocProc;
- ClockFmtScnStorageHashKeyType.freeEntryProc = ClockFmtScnStorageFreeProc;
-
- /* initialize hash table */
- Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS,
- &ClockFmtScnStorageHashKeyType);
-
- initialized = 1;
- }
-
- /* get or create entry (and alocate storage) */
- hPtr = Tcl_CreateHashEntry(&FmtScnHashTable, strFmt, &isNew);
- if (hPtr != NULL) {
- fss = FmtScn4HashEntry(hPtr);
-
-#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
- /* unlink if it is currently in GC */
- if (isNew == 0 && fss->objRefCount == 0) {
- ClockFmtScnStorage_GC_Out(fss);
- }
-#endif
-
- /* new reference, so increment in lock right now */
- fss->objRefCount++;
- ObjClockFmtScn(objPtr) = fss;
- }
-
- Tcl_MutexUnlock(&ClockFmtMutex);
-
- if (fss == NULL && interp != NULL) {
- Tcl_AppendResult(interp, "retrieve clock format failed \"",
- strFmt ? strFmt : "", "\"", NULL);
- Tcl_SetErrorCode(interp, "TCL", "EINVAL", (char *)NULL);
- }
-
- return fss;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetClockFrmScnFromObj --
- *
- * Returns a clock format/scan representation of (*objPtr), if possible.
- * If something goes wrong, NULL is returned, and if interp is non-NULL,
- * an error message is written there.
- *
- * Results:
- * Valid representation of type ClockFmtScnStorage.
- *
- * Side effects:
- * Caches the ClockFmtScnStorage reference as the internal rep of (*objPtr)
- * and in global hash table, shared across all threads.
- *
- *----------------------------------------------------------------------
- */
-
-ClockFmtScnStorage *
-Tcl_GetClockFrmScnFromObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- ClockFmtScnStorage *fss;
-
- if (objPtr->typePtr != &ClockFmtObjType) {
- if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) {
- return NULL;
- }
- }
-
- fss = ObjClockFmtScn(objPtr);
-
- if (fss == NULL) {
- fss = FindOrCreateFmtScnStorage(interp, objPtr);
- }
-
- return fss;
-}
-/*
- *----------------------------------------------------------------------
- *
- * ClockLocalizeFormat --
- *
- * Wrap the format object in options to the localized format,
- * corresponding given locale.
- *
- * This searches localized format in locale catalog, and if not yet
- * exists, it executes ::tcl::clock::LocalizeFormat in given interpreter
- * and caches its result in the locale catalog.
- *
- * Results:
- * Localized format object.
- *
- * Side effects:
- * Caches the localized format inside locale catalog.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-ClockLocalizeFormat(
- ClockFmtScnCmdArgs *opts)
-{
- ClockClientData *dataPtr = opts->dataPtr;
- Tcl_Obj *valObj = NULL, *keyObj;
-
- keyObj = ClockFrmObjGetLocFmtKey(opts->interp, opts->formatObj);
-
- /* special case - format object is not localizable */
- if (keyObj == opts->formatObj) {
- return opts->formatObj;
- }
-
- /* prevents loss of key object if the format object (where key stored)
- * becomes changed (loses its internal representation during evals) */
- Tcl_IncrRefCount(keyObj);
-
- if (opts->mcDictObj == NULL) {
- ClockMCDict(opts);
- if (opts->mcDictObj == NULL) {
- goto done;
- }
- }
-
- /* try to find in cache within locale mc-catalog */
- if (Tcl_DictObjGet(NULL, opts->mcDictObj, keyObj, &valObj) != TCL_OK) {
- goto done;
- }
-
- /* call LocalizeFormat locale format fmtkey */
- if (valObj == NULL) {
- Tcl_Obj *callargs[4];
-
- callargs[0] = dataPtr->literals[LIT_LOCALIZE_FORMAT];
- callargs[1] = opts->localeObj;
- callargs[2] = opts->formatObj;
- callargs[3] = opts->mcDictObj;
- if (Tcl_EvalObjv(opts->interp, 4, callargs, 0) == TCL_OK) {
- valObj = Tcl_GetObjResult(opts->interp);
- }
-
- /* ensure mcDictObj remains unshared */
- if (opts->mcDictObj->refCount > 1) {
- /* smart reference (shared dict as object with no ref-counter) */
- opts->mcDictObj = TclDictObjSmartRef(opts->interp,
- opts->mcDictObj);
- }
- if (!valObj) {
- goto done;
- }
- /* cache it inside mc-dictionary (this incr. ref count of keyObj/valObj) */
- if (Tcl_DictObjPut(opts->interp, opts->mcDictObj, keyObj, valObj) != TCL_OK) {
- valObj = NULL;
- goto done;
- }
-
- Tcl_ResetResult(opts->interp);
-
- /* check special case - format object is not localizable */
- if (valObj == opts->formatObj) {
- /* mark it as unlocalizable, by setting self as key (without refcount incr) */
- if (valObj->typePtr == &ClockFmtObjType) {
- TclUnsetObjRef(ObjLocFmtKey(valObj));
- ObjLocFmtKey(valObj) = valObj;
- }
- }
- }
-
-done:
-
- TclUnsetObjRef(keyObj);
- return (opts->formatObj = valObj);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FindTokenBegin --
- *
- * Find begin of given scan token in string, corresponding token type.
- *
- * Results:
- * Position of token inside string if found. Otherwise - end of string.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static const char *
-FindTokenBegin(
- const char *p,
- const char *end,
- ClockScanToken *tok,
- int flags)
-{
- if (p < end) {
- char c;
-
- /* next token a known token type */
- switch (tok->map->type) {
- case CTOKT_INT:
- case CTOKT_WIDE:
- if (!(flags & CLF_STRICT)) {
- /* should match at least one digit or space */
- while (!isdigit(UCHAR(*p)) && !isspace(UCHAR(*p)) &&
- (p = Tcl_UtfNext(p)) < end) {}
- } else {
- /* should match at least one digit */
- while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {}
- }
- return p;
-
- case CTOKT_WORD:
- c = *(tok->tokWord.start);
- goto findChar;
-
- case CTOKT_SPACE:
- while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {}
- return p;
-
- case CTOKT_CHAR:
- c = *((char *)tok->map->data);
-findChar:
- if (!(flags & CLF_STRICT)) {
- /* should match the char or space */
- while (*p != c && !isspace(UCHAR(*p)) &&
- (p = Tcl_UtfNext(p)) < end) {}
- } else {
- /* should match the char */
- while (*p != c && (p = Tcl_UtfNext(p)) < end) {}
- }
- return p;
- }
- }
- return p;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DetermineGreedySearchLen --
- *
- * Determine min/max lengths as exact as possible (speed, greedy match).
- *
- * Results:
- * None. Lengths are stored in *minLenPtr, *maxLenPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DetermineGreedySearchLen(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok,
- int *minLenPtr,
- int *maxLenPtr)
-{
- int minLen = tok->map->minSize;
- int maxLen;
- const char *p = yyInput + minLen;
- const char *end = info->dateEnd;
-
- /* if still tokens available, try to correct minimum length */
- if ((tok + 1)->map) {
- end -= tok->endDistance + yySpaceCount;
- /* find position of next known token */
- p = FindTokenBegin(p, end, tok + 1,
- TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT);
- if (p < end) {
- minLen = p - yyInput;
- }
- }
-
- /* max length to the end regarding distance to end (min-width of following tokens) */
- maxLen = end - yyInput;
- /* several amendments */
- if (maxLen > tok->map->maxSize) {
- maxLen = tok->map->maxSize;
- }
- if (minLen < tok->map->minSize) {
- minLen = tok->map->minSize;
- }
- if (minLen > maxLen) {
- maxLen = minLen;
- }
- if (maxLen > info->dateEnd - yyInput) {
- maxLen = info->dateEnd - yyInput;
- }
-
- /* check digits rigth now */
- if (tok->map->type == CTOKT_INT || tok->map->type == CTOKT_WIDE) {
- p = yyInput;
- end = p + maxLen;
- if (end > info->dateEnd) {
- end = info->dateEnd;
- }
- while (isdigit(UCHAR(*p)) && p < end) {
- p++;
- }
- maxLen = p - yyInput;
- }
-
- /* try to get max length more precise for greedy match,
- * check the next ahead token available there */
- if (minLen < maxLen && tok->lookAhTok) {
- ClockScanToken *laTok = tok + tok->lookAhTok + 1;
-
- p = yyInput + maxLen;
- /* regards all possible spaces here (because they are optional) */
- end = p + tok->lookAhMax + yySpaceCount + 1;
- if (end > info->dateEnd) {
- end = info->dateEnd;
- }
- p += tok->lookAhMin;
- if (laTok->map && p < end) {
-
- /* try to find laTok between [lookAhMin, lookAhMax] */
- while (minLen < maxLen) {
- const char *f = FindTokenBegin(p, end, laTok,
- TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT);
- /* if found (not below lookAhMax) */
- if (f < end) {
- break;
- }
- /* try again with fewer length */
- maxLen--;
- p--;
- end--;
- }
- } else if (p > end) {
- maxLen -= (p - end);
- if (maxLen < minLen) {
- maxLen = minLen;
- }
- }
- }
-
- *minLenPtr = minLen;
- *maxLenPtr = maxLen;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ObjListSearch --
- *
- * Find largest part of the input string from start regarding min and
- * max lengths in the given list (utf-8, case sensitive).
- *
- * Results:
- * TCL_OK - match found, TCL_RETURN - not matched, TCL_ERROR in error case.
- *
- * Side effects:
- * Input points to end of the found token in string.
- *
- *----------------------------------------------------------------------
- */
-
-static inline int
-ObjListSearch(
- DateInfo *info,
- int *val,
- Tcl_Obj **lstv,
- Tcl_Size lstc,
- int minLen,
- int maxLen)
-{
- Tcl_Size i, l, lf = -1;
- const char *s, *f, *sf;
-
- /* search in list */
- for (i = 0; i < lstc; i++) {
- s = TclGetStringFromObj(lstv[i], &l);
-
- if (l >= minLen
- && (f = TclUtfFindEqualNC(yyInput, yyInput + maxLen, s, s + l, &sf)) > yyInput) {
- l = f - yyInput;
- if (l < minLen) {
- continue;
- }
- /* found, try to find longest value (greedy search) */
- if (l < maxLen && minLen != maxLen) {
- lf = i;
- minLen = l + 1;
- continue;
- }
- /* max possible - end of search */
- *val = i;
- yyInput += l;
- break;
- }
- }
-
- /* if found */
- if (i < lstc) {
- return TCL_OK;
- }
- if (lf >= 0) {
- *val = lf;
- yyInput += minLen - 1;
- return TCL_OK;
- }
- return TCL_RETURN;
-}
-#if 0
-/* currently unused */
-
-static int
-LocaleListSearch(ClockFmtScnCmdArgs *opts,
- DateInfo *info, int mcKey, int *val,
- int minLen, int maxLen)
-{
- Tcl_Obj **lstv;
- Tcl_Size lstc;
- Tcl_Obj *valObj;
-
- /* get msgcat value */
- valObj = ClockMCGet(opts, mcKey);
- if (valObj == NULL) {
- return TCL_ERROR;
- }
-
- /* is a list */
- if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /* search in list */
- return ObjListSearch(info, val, lstv, lstc,
- minLen, maxLen);
-}
-#endif
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCGetListIdxTree --
- *
- * Retrieves localized string indexed tree in the locale catalog for
- * given literal index mcKey (and builds it on demand).
- *
- * Searches localized index in locale catalog, and if not yet exists,
- * creates string indexed tree and stores it in the locale catalog.
- *
- * Results:
- * Localized string index tree.
- *
- * Side effects:
- * Caches the localized string index tree inside locale catalog.
- *
- *----------------------------------------------------------------------
- */
-
-static TclStrIdxTree *
-ClockMCGetListIdxTree(
- ClockFmtScnCmdArgs *opts,
- int mcKey)
-{
- TclStrIdxTree *idxTree;
- Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey);
-
- if (objPtr != NULL
- && (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL) {
- return idxTree;
- } else {
- /* build new index */
-
- Tcl_Obj **lstv;
- Tcl_Size lstc;
- Tcl_Obj *valObj;
-
- objPtr = TclStrIdxTreeNewObj();
- if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) {
- goto done; /* unexpected, but ...*/
- }
-
- valObj = ClockMCGet(opts, mcKey);
- if (valObj == NULL) {
- goto done;
- }
- if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
- goto done;
- }
- if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv, NULL) != TCL_OK) {
- goto done;
- }
-
- ClockMCSetIdx(opts, mcKey, objPtr);
- objPtr = NULL;
- }
-
- done:
- if (objPtr) {
- Tcl_DecrRefCount(objPtr);
- idxTree = NULL;
- }
-
- return idxTree;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockMCGetMultiListIdxTree --
- *
- * Retrieves localized string indexed tree in the locale catalog for
- * multiple lists by literal indices mcKeys (and builds it on demand).
- *
- * Searches localized index in locale catalog for mcKey, and if not
- * yet exists, creates string indexed tree and stores it in the
- * locale catalog.
- *
- * Results:
- * Localized string index tree.
- *
- * Side effects:
- * Caches the localized string index tree inside locale catalog.
- *
- *----------------------------------------------------------------------
- */
-
-static TclStrIdxTree *
-ClockMCGetMultiListIdxTree(
- ClockFmtScnCmdArgs *opts,
- int mcKey,
- int *mcKeys)
-{
- TclStrIdxTree * idxTree;
- Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey);
-
- if (objPtr != NULL
- && (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL) {
- return idxTree;
- } else {
- /* build new index */
-
- Tcl_Obj **lstv;
- Tcl_Size lstc;
- Tcl_Obj *valObj;
-
- objPtr = TclStrIdxTreeNewObj();
- if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) {
- goto done; /* unexpected, but ...*/
- }
-
- while (*mcKeys) {
- valObj = ClockMCGet(opts, *mcKeys);
- if (valObj == NULL) {
- goto done;
- }
- if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) {
- goto done;
- }
- if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv, NULL) != TCL_OK) {
- goto done;
- }
- mcKeys++;
- }
-
- ClockMCSetIdx(opts, mcKey, objPtr);
- objPtr = NULL;
- }
-
- done:
- if (objPtr) {
- Tcl_DecrRefCount(objPtr);
- idxTree = NULL;
- }
-
- return idxTree;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ClockStrIdxTreeSearch --
- *
- * Find largest part of the input string from start regarding lengths
- * in the given localized string indexed tree (utf-8, case sensitive).
- *
- * Results:
- * TCL_OK - match found and the index stored in *val,
- * TCL_RETURN - not matched or ambigous,
- * TCL_ERROR - in error case.
- *
- * Side effects:
- * Input points to end of the found token in string.
- *
- *----------------------------------------------------------------------
- */
-
-static inline int
-ClockStrIdxTreeSearch(
- DateInfo *info,
- TclStrIdxTree *idxTree,
- int *val,
- int minLen,
- int maxLen)
-{
- TclStrIdx *foundItem;
- const char *f = TclStrIdxTreeSearch(NULL, &foundItem, idxTree,
- yyInput, yyInput + maxLen);
-
- if (f <= yyInput || (f - yyInput) < minLen) {
- /* not found */
- return TCL_RETURN;
- }
- if (!foundItem->value) {
- /* ambigous */
- return TCL_RETURN;
- }
-
- *val = PTR2INT(foundItem->value);
-
- /* shift input pointer */
- yyInput = f;
-
- return TCL_OK;
-}
-#if 0
-/* currently unused */
-
-static int
-StaticListSearch(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- const char **lst,
- int *val)
-{
- size_t len;
- const char **s = lst;
-
- while (*s != NULL) {
- len = strlen(*s);
- if (len <= info->dateEnd - yyInput
- && strncasecmp(yyInput, *s, len) == 0) {
- *val = (s - lst);
- yyInput += len;
- break;
- }
- s++;
- }
- if (*s != NULL) {
- return TCL_OK;
- }
- return TCL_RETURN;
-}
-#endif
-
-static inline const char *
-FindWordEnd(
- ClockScanToken *tok,
- const char *p,
- const char *end)
-{
- const char *x = tok->tokWord.start;
- const char *pfnd = p;
-
- if (x == tok->tokWord.end - 1) { /* fast phase-out for single char word */
- if (*p == *x) {
- return ++p;
- }
- }
- /* multi-char word */
- x = TclUtfFindEqualNC(x, tok->tokWord.end, p, end, &pfnd);
- if (x < tok->tokWord.end) {
- /* no match -> error */
- return NULL;
- }
- return pfnd;
-}
-
-static int
-ClockScnToken_Month_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
-#if 0
-/* currently unused, test purposes only */
- static const char * months[] = {
- /* full */
- "January", "February", "March",
- "April", "May", "June",
- "July", "August", "September",
- "October", "November", "December",
- /* abbr */
- "Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec",
- NULL
- };
- int val;
- if (StaticListSearch(opts, info, months, &val) != TCL_OK) {
- return TCL_RETURN;
- }
- yyMonth = (val % 12) + 1;
-#else
- static int monthsKeys[] = {MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, 0};
-
- int ret, val;
- int minLen, maxLen;
- TclStrIdxTree *idxTree;
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- /* get or create tree in msgcat dict */
-
- idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_MONTHS_COMB, monthsKeys);
- if (idxTree == NULL) {
- return TCL_ERROR;
- }
-
- ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
-
- yyMonth = val;
-#endif
- return TCL_OK;
-}
-
-static int
-ClockScnToken_DayOfWeek_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- static int dowKeys[] = {MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_FULL, 0};
-
- int ret, val;
- int minLen, maxLen;
- char curTok = *tok->tokWord.start;
- TclStrIdxTree *idxTree;
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- /* %u %w %Ou %Ow */
- if (curTok != 'a' && curTok != 'A'
- && ((minLen <= 1 && maxLen >= 1) || PTR2INT(tok->map->data))) {
- val = -1;
-
- if (PTR2INT(tok->map->data) == 0) {
- if (*yyInput >= '0' && *yyInput <= '9') {
- val = *yyInput - '0';
- }
- } else {
- idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */);
- if (idxTree == NULL) {
- return TCL_ERROR;
- }
-
- ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
- --val;
- }
-
- if (val == -1) {
- return TCL_RETURN;
- }
-
- if (val == 0) {
- val = 7;
- }
- if (val > 7) {
- Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
- "day of week is greater than 7", TCL_AUTO_LENGTH));
- Tcl_SetErrorCode(opts->interp, "CLOCK", "badDayOfWeek", (char *)NULL);
- return TCL_ERROR;
- }
- info->date.dayOfWeek = val;
- yyInput++;
- return TCL_OK;
- }
-
- /* %a %A */
- idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_DAYS_OF_WEEK_COMB, dowKeys);
- if (idxTree == NULL) {
- return TCL_ERROR;
- }
-
- ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
- --val;
-
- if (val == 0) {
- val = 7;
- }
- info->date.dayOfWeek = val;
- return TCL_OK;
-}
-
-static int
-ClockScnToken_amPmInd_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- int ret, val;
- int minLen, maxLen;
- Tcl_Obj *amPmObj[2];
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- amPmObj[0] = ClockMCGet(opts, MCLIT_AM);
- amPmObj[1] = ClockMCGet(opts, MCLIT_PM);
-
- if (amPmObj[0] == NULL || amPmObj[1] == NULL) {
- return TCL_ERROR;
- }
-
- ret = ObjListSearch(info, &val, amPmObj, 2, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
-
- if (val == 0) {
- yyMeridian = MERam;
- } else {
- yyMeridian = MERpm;
- }
-
- return TCL_OK;
-}
-
-static int
-ClockScnToken_LocaleERA_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- ClockClientData *dataPtr = opts->dataPtr;
-
- int ret, val;
- int minLen, maxLen;
- Tcl_Obj *eraObj[6];
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- eraObj[0] = ClockMCGet(opts, MCLIT_BCE);
- eraObj[1] = ClockMCGet(opts, MCLIT_CE);
- eraObj[2] = dataPtr->mcLiterals[MCLIT_BCE2];
- eraObj[3] = dataPtr->mcLiterals[MCLIT_CE2];
- eraObj[4] = dataPtr->mcLiterals[MCLIT_BCE3];
- eraObj[5] = dataPtr->mcLiterals[MCLIT_CE3];
-
- if (eraObj[0] == NULL || eraObj[1] == NULL) {
- return TCL_ERROR;
- }
-
- ret = ObjListSearch(info, &val, eraObj, 6, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
-
- if (val & 1) {
- yydate.isBce = 0;
- } else {
- yydate.isBce = 1;
- }
-
- return TCL_OK;
-}
-
-static int
-ClockScnToken_LocaleListMatcher_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- int ret, val;
- int minLen, maxLen;
- TclStrIdxTree *idxTree;
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- /* get or create tree in msgcat dict */
-
- idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */);
- if (idxTree == NULL) {
- return TCL_ERROR;
- }
-
- ret = ClockStrIdxTreeSearch(info, idxTree, &val, minLen, maxLen);
- if (ret != TCL_OK) {
- return ret;
- }
-
- if (tok->map->offs > 0) {
- *IntFieldAt(info, tok->map->offs) = --val;
- }
-
- return TCL_OK;
-}
-
-static int
-ClockScnToken_JDN_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- int minLen, maxLen;
- const char *p = yyInput, *end, *s;
- Tcl_WideInt intJD;
- int fractJD = 0, fractJDDiv = 1;
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- end = yyInput + maxLen;
-
- /* currently positive astronomic dates only */
- if (*p == '+' || *p == '-') {
- p++;
- }
- s = p;
- while (p < end && isdigit(UCHAR(*p))) {
- p++;
- }
- if (Clock_str2wideInt(&intJD, s, p, (*yyInput != '-' ? 1 : -1)) != TCL_OK) {
- return TCL_RETURN;
- }
- yyInput = p;
- if (p >= end || *p++ != '.') { /* allow pure integer JDN */
- /* by astronomical JD the seconds of day offs is 12 hours */
- if (tok->map->offs) {
- goto done;
- }
- /* calendar JD */
- yydate.julianDay = intJD;
- return TCL_OK;
- }
- s = p;
- while (p < end && isdigit(UCHAR(*p))) {
- fractJDDiv *= 10;
- p++;
- }
- if (Clock_str2int(&fractJD, s, p, 1) != TCL_OK) {
- return TCL_RETURN;
- }
- yyInput = p;
-
- done:
- /*
- * Build a date from julian day (integer and fraction).
- * Note, astronomical JDN starts at noon in opposite to calendar julianday.
- */
-
- fractJD = (int)tok->map->offs /* 0 for calendar or 43200 for astro JD */
- + (int)((Tcl_WideInt)SECONDS_PER_DAY * fractJD / fractJDDiv);
- if (fractJD > SECONDS_PER_DAY) {
- fractJD %= SECONDS_PER_DAY;
- intJD += 1;
- }
- yydate.secondOfDay = fractJD;
- yydate.julianDay = intJD;
-
- yydate.seconds =
- -210866803200LL
- + (SECONDS_PER_DAY * intJD)
- + fractJD;
-
- info->flags |= CLF_POSIXSEC;
-
- return TCL_OK;
-}
-
-static int
-ClockScnToken_TimeZone_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- int minLen, maxLen;
- int len = 0;
- const char *p = yyInput;
- Tcl_Obj *tzObjStor = NULL;
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- /* numeric timezone */
- if (*p == '+' || *p == '-') {
- /* max chars in numeric zone = "+00:00:00" */
-#define MAX_ZONE_LEN 9
- char buf[MAX_ZONE_LEN + 1];
- char *bp = buf;
-
- *bp++ = *p++;
- len++;
- if (maxLen > MAX_ZONE_LEN) {
- maxLen = MAX_ZONE_LEN;
- }
- /* cumulate zone into buf without ':' */
- while (len + 1 < maxLen) {
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- *bp++ = *p++;
- len++;
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- *bp++ = *p++;
- len++;
- if (len + 2 < maxLen) {
- if (*p == ':') {
- p++;
- len++;
- }
- }
- }
- *bp = '\0';
-
- if (len < minLen) {
- return TCL_RETURN;
- }
-#undef MAX_ZONE_LEN
-
- /* timezone */
- tzObjStor = Tcl_NewStringObj(buf, bp - buf);
- } else {
- /* legacy (alnum) timezone like CEST, etc. */
- if (maxLen > 4) {
- maxLen = 4;
- }
- while (len < maxLen) {
- if ((*p & 0x80)
- || (!isalpha(UCHAR(*p)) && !isdigit(UCHAR(*p)))) { /* INTL: ISO only. */
- break;
- }
- p++;
- len++;
- }
-
- if (len < minLen) {
- return TCL_RETURN;
- }
-
- /* timezone */
- tzObjStor = Tcl_NewStringObj(yyInput, p - yyInput);
-
- /* convert using dict */
- }
-
- /* try to apply new time zone */
- Tcl_IncrRefCount(tzObjStor);
-
- opts->timezoneObj = ClockSetupTimeZone(opts->dataPtr, opts->interp,
- tzObjStor);
-
- Tcl_DecrRefCount(tzObjStor);
- if (opts->timezoneObj == NULL) {
- return TCL_ERROR;
- }
-
- yyInput += len;
- return TCL_OK;
-}
-
-static int
-ClockScnToken_StarDate_Proc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok)
-{
- int minLen, maxLen;
- const char *p = yyInput, *end, *s;
- int year, fractYear, fractDayDiv, fractDay;
- static const char *stardatePref = "stardate ";
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen);
-
- end = yyInput + maxLen;
-
- /* stardate string */
- p = TclUtfFindEqualNCInLwr(p, end, stardatePref, stardatePref + 9, &s);
- if (p >= end || p - yyInput < 9) {
- return TCL_RETURN;
- }
- /* bypass spaces */
- while (p < end && isspace(UCHAR(*p))) {
- p++;
- }
- if (p >= end) {
- return TCL_RETURN;
- }
- /* currently positive stardate only */
- if (*p == '+') {
- p++;
- }
- s = p;
- while (p < end && isdigit(UCHAR(*p))) {
- p++;
- }
- if (p >= end || p - s < 4) {
- return TCL_RETURN;
- }
- if (Clock_str2int(&year, s, p - 3, 1) != TCL_OK
- || Clock_str2int(&fractYear, p - 3, p, 1) != TCL_OK) {
- return TCL_RETURN;
- }
- if (*p++ != '.') {
- return TCL_RETURN;
- }
- s = p;
- fractDayDiv = 1;
- while (p < end && isdigit(UCHAR(*p))) {
- fractDayDiv *= 10;
- p++;
- }
- if (Clock_str2int(&fractDay, s, p, 1) != TCL_OK) {
- return TCL_RETURN;
- }
- yyInput = p;
-
- /* Build a date from year and fraction. */
-
- yydate.year = year + RODDENBERRY;
- yydate.isBce = 0;
- yydate.gregorian = 1;
-
- if (IsGregorianLeapYear(&yydate)) {
- fractYear *= 366;
- } else {
- fractYear *= 365;
- }
- yydate.dayOfYear = fractYear / 1000 + 1;
- if (fractYear % 1000 >= 500) {
- yydate.dayOfYear++;
- }
-
- GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE);
-
- yydate.localSeconds =
- -210866803200LL
- + (SECONDS_PER_DAY * yydate.julianDay)
- + (SECONDS_PER_DAY * fractDay / fractDayDiv);
-
- return TCL_OK;
-}
-
-/*
- * Descriptors for the various fields in [clock scan].
- */
-
-static const char *ScnSTokenMapIndex = "dmbyYHMSpJjCgGVazUsntQ";
-static const ClockScanTokenMap ScnSTokenMap[] = {
- /* %d %e */
- {CTOKT_INT, CLF_DAYOFMONTH, 0, 1, 2, offsetof(DateInfo, date.dayOfMonth),
- NULL, NULL},
- /* %m %N */
- {CTOKT_INT, CLF_MONTH, 0, 1, 2, offsetof(DateInfo, date.month),
- NULL, NULL},
- /* %b %B %h */
- {CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, 0,
- ClockScnToken_Month_Proc, NULL},
- /* %y */
- {CTOKT_INT, CLF_YEAR, 0, 1, 2, offsetof(DateInfo, date.year),
- NULL, NULL},
- /* %Y */
- {CTOKT_INT, CLF_YEAR | CLF_CENTURY, 0, 4, 4, offsetof(DateInfo, date.year),
- NULL, NULL},
- /* %H %k %I %l */
- {CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.hour),
- NULL, NULL},
- /* %M */
- {CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.minutes),
- NULL, NULL},
- /* %S */
- {CTOKT_INT, CLF_TIME, 0, 1, 2, offsetof(DateInfo, date.secondOfMin),
- NULL, NULL},
- /* %p %P */
- {CTOKT_PARSER, 0, 0, 0, 0xffff, 0,
- ClockScnToken_amPmInd_Proc, NULL},
- /* %J */
- {CTOKT_WIDE, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.julianDay),
- NULL, NULL},
- /* %j */
- {CTOKT_INT, CLF_DAYOFYEAR, 0, 1, 3, offsetof(DateInfo, date.dayOfYear),
- NULL, NULL},
- /* %C */
- {CTOKT_INT, CLF_CENTURY|CLF_ISO8601CENTURY, 0, 1, 2, offsetof(DateInfo, dateCentury),
- NULL, NULL},
- /* %g */
- {CTOKT_INT, CLF_ISO8601YEAR, 0, 2, 2, offsetof(DateInfo, date.iso8601Year),
- NULL, NULL},
- /* %G */
- {CTOKT_INT, CLF_ISO8601YEAR | CLF_ISO8601CENTURY, 0, 4, 4, offsetof(DateInfo, date.iso8601Year),
- NULL, NULL},
- /* %V */
- {CTOKT_INT, CLF_ISO8601WEEK, 0, 1, 2, offsetof(DateInfo, date.iso8601Week),
- NULL, NULL},
- /* %a %A %u %w */
- {CTOKT_PARSER, CLF_DAYOFWEEK, 0, 0, 0xffff, 0,
- ClockScnToken_DayOfWeek_Proc, NULL},
- /* %z %Z */
- {CTOKT_PARSER, CLF_OPTIONAL, 0, 0, 0xffff, 0,
- ClockScnToken_TimeZone_Proc, NULL},
- /* %U %W */
- {CTOKT_INT, CLF_OPTIONAL, 0, 1, 2, 0, /* currently no capture, parse only token */
- NULL, NULL},
- /* %s */
- {CTOKT_WIDE, CLF_POSIXSEC | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.seconds),
- NULL, NULL},
- /* %n */
- {CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\n"},
- /* %t */
- {CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\t"},
- /* %Q */
- {CTOKT_PARSER, CLF_LOCALSEC, 0, 16, 30, 0,
- ClockScnToken_StarDate_Proc, NULL},
-};
-static const char *ScnSTokenMapAliasIndex[2] = {
- "eNBhkIlPAuwZW",
- "dmbbHHHpaaazU"
-};
-
-static const char *ScnETokenMapIndex = "EJjys";
-static const ClockScanTokenMap ScnETokenMap[] = {
- /* %EE */
- {CTOKT_PARSER, 0, 0, 0, 0xffff, offsetof(DateInfo, date.year),
- ClockScnToken_LocaleERA_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %EJ */
- {CTOKT_PARSER, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, 0, /* calendar JDN starts at midnight */
- ClockScnToken_JDN_Proc, NULL},
- /* %Ej */
- {CTOKT_PARSER, CLF_JULIANDAY | CLF_SIGNED, 0, 1, 0xffff, (SECONDS_PER_DAY/2), /* astro JDN starts at noon */
- ClockScnToken_JDN_Proc, NULL},
- /* %Ey */
- {CTOKT_PARSER, 0, 0, 0, 0xffff, 0, /* currently no capture, parse only token */
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Es */
- {CTOKT_WIDE, CLF_LOCALSEC | CLF_SIGNED, 0, 1, 0xffff, offsetof(DateInfo, date.localSeconds),
- NULL, NULL},
-};
-static const char *ScnETokenMapAliasIndex[2] = {
- "",
- ""
-};
-
-static const char *ScnOTokenMapIndex = "dmyHMSu";
-static const ClockScanTokenMap ScnOTokenMap[] = {
- /* %Od %Oe */
- {CTOKT_PARSER, CLF_DAYOFMONTH, 0, 0, 0xffff, offsetof(DateInfo, date.dayOfMonth),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Om */
- {CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, offsetof(DateInfo, date.month),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Oy */
- {CTOKT_PARSER, CLF_YEAR, 0, 0, 0xffff, offsetof(DateInfo, date.year),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OH %Ok %OI %Ol */
- {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.hour),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OM */
- {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.minutes),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OS */
- {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, offsetof(DateInfo, date.secondOfMin),
- ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Ou Ow */
- {CTOKT_PARSER, CLF_DAYOFWEEK, 0, 0, 0xffff, 0,
- ClockScnToken_DayOfWeek_Proc, (void *)MCLIT_LOCALE_NUMERALS},
-};
-static const char *ScnOTokenMapAliasIndex[2] = {
- "ekIlw",
- "dHHHu"
-};
-
-/* Token map reserved for CTOKT_SPACE */
-static const ClockScanTokenMap ScnSpaceTokenMap = {
- CTOKT_SPACE, 0, 0, 1, 1, 0, NULL, NULL
-};
-
-static const ClockScanTokenMap ScnWordTokenMap = {
- CTOKT_WORD, 0, 0, 1, 1, 0, NULL, NULL
-};
-
-static inline unsigned
-EstimateTokenCount(
- const char *fmt,
- const char *end)
-{
- const char *p = fmt;
- unsigned tokcnt;
- /* estimate token count by % char and format length */
- tokcnt = 0;
- while (p <= end) {
- if (*p++ == '%') {
- tokcnt++;
- p++;
- }
- }
- p = fmt + tokcnt * 2;
- if (p < end) {
- if ((unsigned)(end - p) < tokcnt) {
- tokcnt += (end - p);
- } else {
- tokcnt += tokcnt;
- }
- }
- return ++tokcnt;
-}
-
-#define AllocTokenInChain(tok, chain, tokCnt, type) \
- if (++(tok) >= (chain) + (tokCnt)) { \
- chain = (type)Tcl_Realloc((char *)(chain), \
- (tokCnt + CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE) * sizeof(*(tok))); \
- (tok) = (chain) + (tokCnt); \
- (tokCnt) += CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE; \
- } \
- memset(tok, 0, sizeof(*(tok)));
-
-/*
- *----------------------------------------------------------------------
- */
-ClockFmtScnStorage *
-ClockGetOrParseScanFormat(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *formatObj) /* Format container */
-{
- ClockFmtScnStorage *fss;
-
- fss = Tcl_GetClockFrmScnFromObj(interp, formatObj);
- if (fss == NULL) {
- return NULL;
- }
-
- /* if format (scnTok) already tokenized */
- if (fss->scnTok != NULL) {
- return fss;
- }
-
- Tcl_MutexLock(&ClockFmtMutex);
-
- /* first time scanning - tokenize format */
- if (fss->scnTok == NULL) {
- ClockScanToken *tok, *scnTok;
- unsigned tokCnt;
- const char *p, *e, *cp;
-
- e = p = HashEntry4FmtScn(fss)->key.string;
- e += strlen(p);
-
- /* estimate token count by % char and format length */
- fss->scnTokC = EstimateTokenCount(p, e);
-
- fss->scnSpaceCount = 0;
-
- scnTok = tok = (ClockScanToken *)Tcl_Alloc(sizeof(*tok) * fss->scnTokC);
- memset(tok, 0, sizeof(*tok));
- tokCnt = 1;
- while (p < e) {
- switch (*p) {
- case '%': {
- const ClockScanTokenMap *scnMap = ScnSTokenMap;
- const char *mapIndex = ScnSTokenMapIndex;
- const char **aliasIndex = ScnSTokenMapAliasIndex;
-
- if (p + 1 >= e) {
- goto word_tok;
- }
- p++;
- /* try to find modifier: */
- switch (*p) {
- case '%':
- /* begin new word token - don't join with previous word token,
- * because current mapping should be "...%%..." -> "...%..." */
- tok->map = &ScnWordTokenMap;
- tok->tokWord.start = p;
- tok->tokWord.end = p + 1;
- AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
- tokCnt++;
- p++;
- continue;
- case 'E':
- scnMap = ScnETokenMap,
- mapIndex = ScnETokenMapIndex,
- aliasIndex = ScnETokenMapAliasIndex;
- p++;
- break;
- case 'O':
- scnMap = ScnOTokenMap,
- mapIndex = ScnOTokenMapIndex,
- aliasIndex = ScnOTokenMapAliasIndex;
- p++;
- break;
- }
- /* search direct index */
- cp = strchr(mapIndex, *p);
- if (!cp || *cp == '\0') {
- /* search wrapper index (multiple chars for same token) */
- cp = strchr(aliasIndex[0], *p);
- if (!cp || *cp == '\0') {
- p--;
- if (scnMap != ScnSTokenMap) {
- p--;
- }
- goto word_tok;
- }
- cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]);
- if (!cp || *cp == '\0') { /* unexpected, but ... */
-#ifdef DEBUG
- Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p);
-#endif
- p--;
- if (scnMap != ScnSTokenMap) {
- p--;
- }
- goto word_tok;
- }
- }
- tok->map = &scnMap[cp - mapIndex];
- tok->tokWord.start = p;
-
- /* calculate look ahead value by standing together tokens */
- if (tok > scnTok) {
- ClockScanToken *prevTok = tok - 1;
-
- while (prevTok >= scnTok) {
- if (prevTok->map->type != tok->map->type) {
- break;
- }
- prevTok->lookAhMin += tok->map->minSize;
- prevTok->lookAhMax += tok->map->maxSize;
- prevTok->lookAhTok++;
- prevTok--;
- }
- }
-
- /* increase space count used in format */
- if (tok->map->type == CTOKT_CHAR
- && isspace(UCHAR(*((char *)tok->map->data)))) {
- fss->scnSpaceCount++;
- }
-
- /* next token */
- AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
- tokCnt++;
- p++;
- continue;
- }
- default:
- if (isspace(UCHAR(*p))) {
- tok->map = &ScnSpaceTokenMap;
- tok->tokWord.start = p++;
- while (p < e && isspace(UCHAR(*p))) {
- p++;
- }
- tok->tokWord.end = p;
- /* increase space count used in format */
- fss->scnSpaceCount++;
- /* next token */
- AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
- tokCnt++;
- continue;
- }
- word_tok:
- {
- /* try continue with previous word token */
- ClockScanToken *wordTok = tok - 1;
-
- if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) {
- /* start with new word token */
- wordTok = tok;
- wordTok->tokWord.start = p;
- wordTok->map = &ScnWordTokenMap;
- }
-
- do {
- if (isspace(UCHAR(*p))) {
- fss->scnSpaceCount++;
- }
- p = Tcl_UtfNext(p);
- } while (p < e && *p != '%');
- wordTok->tokWord.end = p;
-
- if (wordTok == tok) {
- AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *);
- tokCnt++;
- }
- }
- break;
- }
- }
-
- /* calculate end distance value for each tokens */
- if (tok > scnTok) {
- unsigned endDist = 0;
- ClockScanToken *prevTok = tok - 1;
-
- while (prevTok >= scnTok) {
- prevTok->endDistance = endDist;
- if (prevTok->map->type != CTOKT_WORD) {
- endDist += prevTok->map->minSize;
- } else {
- endDist += prevTok->tokWord.end - prevTok->tokWord.start;
- }
- prevTok--;
- }
- }
-
- /* correct count of real used tokens and free mem if desired
- * (1 is acceptable delta to prevent memory fragmentation) */
- if (fss->scnTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) {
- if ((tok = (ClockScanToken *)
- Tcl_AttemptRealloc(scnTok, tokCnt * sizeof(*tok))) != NULL) {
- scnTok = tok;
- }
- }
-
- /* now we're ready - assign now to storage (note the threaded race condition) */
- fss->scnTok = scnTok;
- fss->scnTokC = tokCnt;
- }
-
- Tcl_MutexUnlock(&ClockFmtMutex);
- return fss;
-}
-
-/*
- *----------------------------------------------------------------------
- */
-int
-ClockScan(
- DateInfo *info, /* Date fields used for parsing & converting */
- Tcl_Obj *strObj, /* String containing the time to scan */
- ClockFmtScnCmdArgs *opts) /* Command options */
-{
- ClockClientData *dataPtr = opts->dataPtr;
- ClockFmtScnStorage *fss;
- ClockScanToken *tok;
- const ClockScanTokenMap *map;
- const char *p, *x, *end;
- unsigned short flags = 0;
- int ret = TCL_ERROR;
-
- /* get localized format */
- if (ClockLocalizeFormat(opts) == NULL) {
- return TCL_ERROR;
- }
-
- if (!(fss = ClockGetOrParseScanFormat(opts->interp, opts->formatObj))
- || !(tok = fss->scnTok)) {
- return TCL_ERROR;
- }
-
- /* prepare parsing */
-
- yyMeridian = MER24;
-
- p = TclGetString(strObj);
- end = p + strObj->length;
- /* in strict mode - bypass spaces at begin / end only (not between tokens) */
- if (opts->flags & CLF_STRICT) {
- while (p < end && isspace(UCHAR(*p))) {
- p++;
- }
- }
- yyInput = p;
- /* look ahead to count spaces (bypass it by count length and distances) */
- x = end;
- while (p < end) {
- if (isspace(UCHAR(*p))) {
- x = ++p; /* after first space in space block */
- yySpaceCount++;
- while (p < end && isspace(UCHAR(*p))) {
- p++;
- yySpaceCount++;
- }
- continue;
- }
- x = end;
- p++;
- }
- /* ignore more as 1 space at end */
- yySpaceCount -= (end - x);
- end = x;
- /* ignore mandatory spaces used in format */
- yySpaceCount -= fss->scnSpaceCount;
- if (yySpaceCount < 0) {
- yySpaceCount = 0;
- }
- info->dateStart = p = yyInput;
- info->dateEnd = end;
-
- /* parse string */
- for (; tok->map != NULL; tok++) {
- map = tok->map;
- /* bypass spaces at begin of input before parsing each token */
- if (!(opts->flags & CLF_STRICT)
- && (map->type != CTOKT_SPACE
- && map->type != CTOKT_WORD
- && map->type != CTOKT_CHAR)) {
- while (p < end && isspace(UCHAR(*p))) {
- yySpaceCount--;
- p++;
- }
- }
- yyInput = p;
- /* end of input string */
- if (p >= end) {
- break;
- }
- switch (map->type) {
- case CTOKT_INT:
- case CTOKT_WIDE: {
- int minLen, size;
- int sign = 1;
-
- if (map->flags & CLF_SIGNED) {
- if (*p == '+') {
- yyInput = ++p;
- } else if (*p == '-') {
- yyInput = ++p;
- sign = -1;
- }
- }
-
- DetermineGreedySearchLen(opts, info, tok, &minLen, &size);
-
- if (size < map->minSize) {
- /* missing input -> error */
- if ((map->flags & CLF_OPTIONAL)) {
- continue;
- }
- goto not_match;
- }
- /* string 2 number, put number into info structure by offset */
- if (map->offs) {
- p = yyInput;
- x = p + size;
- if (map->type == CTOKT_INT) {
- if (size <= 10) {
- Clock_str2int_no(IntFieldAt(info, map->offs),
- p, x, sign);
- } else if (Clock_str2int(
- IntFieldAt(info, map->offs), p, x, sign) != TCL_OK) {
- goto overflow;
- }
- p = x;
- } else {
- if (size <= 18) {
- Clock_str2wideInt_no(
- WideFieldAt(info, map->offs), p, x, sign);
- } else if (Clock_str2wideInt(
- WideFieldAt(info, map->offs), p, x, sign) != TCL_OK) {
- goto overflow;
- }
- p = x;
- }
- flags = (flags & ~map->clearFlags) | map->flags;
- }
- break;
- }
- case CTOKT_PARSER:
- switch (map->parser(opts, info, tok)) {
- case TCL_OK:
- break;
- case TCL_RETURN:
- if ((map->flags & CLF_OPTIONAL)) {
- yyInput = p;
- continue;
- }
- goto not_match;
- default:
- goto done;
- }
- /* decrement count for possible spaces in match */
- while (p < yyInput) {
- if (isspace(UCHAR(*p))) {
- yySpaceCount--;
- }
- p++;
- }
- p = yyInput;
- flags = (flags & ~map->clearFlags) | map->flags;
- break;
- case CTOKT_SPACE:
- /* at least one space */
- if (!isspace(UCHAR(*p))) {
- /* unmatched -> error */
- goto not_match;
- }
- /* don't decrement yySpaceCount by regular (first expected space),
- * already considered above with fss->scnSpaceCount */;
- p++;
- while (p < end && isspace(UCHAR(*p))) {
- yySpaceCount--;
- p++;
- }
- break;
- case CTOKT_WORD:
- x = FindWordEnd(tok, p, end);
- if (!x) {
- /* no match -> error */
- goto not_match;
- }
- p = x;
- break;
- case CTOKT_CHAR:
- x = (char *)map->data;
- if (*x != *p) {
- /* no match -> error */
- goto not_match;
- }
- if (isspace(UCHAR(*x))) {
- yySpaceCount--;
- }
- p++;
- break;
- }
- }
- /* check end was reached */
- if (p < end) {
- /* in non-strict mode bypass spaces at end of input */
- if (!(opts->flags & CLF_STRICT) && isspace(UCHAR(*p))) {
- p++;
- while (p < end && isspace(UCHAR(*p))) {
- p++;
- }
- }
- /* something after last token - wrong format */
- if (p < end) {
- goto not_match;
- }
- }
- /* end of string, check only optional tokens at end, otherwise - not match */
- while (tok->map != NULL) {
- if (!(opts->flags & CLF_STRICT) && (tok->map->type == CTOKT_SPACE)) {
- tok++;
- if (tok->map == NULL) {
- /* no tokens anymore - trailing spaces are mandatory */
- goto not_match;
- }
- }
- if (!(tok->map->flags & CLF_OPTIONAL)) {
- goto not_match;
- }
- tok++;
- }
-
- /*
- * Invalidate result
- */
- flags |= info->flags;
-
- /* seconds token (%s) take precedence over all other tokens */
- if ((opts->flags & CLF_EXTENDED) || !(flags & CLF_POSIXSEC)) {
- if (flags & CLF_DATE) {
-
- if (!(flags & CLF_JULIANDAY)) {
- info->flags |= CLF_ASSEMBLE_SECONDS|CLF_ASSEMBLE_JULIANDAY;
-
- /* dd precedence below ddd */
- switch (flags & (CLF_MONTH|CLF_DAYOFYEAR|CLF_DAYOFMONTH)) {
- case (CLF_DAYOFYEAR | CLF_DAYOFMONTH):
- /* miss month: ddd over dd (without month) */
- flags &= ~CLF_DAYOFMONTH;
- /* fallthrough */
- case CLF_DAYOFYEAR:
- /* ddd over naked weekday */
- if (!(flags & CLF_ISO8601YEAR)) {
- flags &= ~CLF_ISO8601WEEK;
- }
- break;
- case CLF_MONTH | CLF_DAYOFYEAR | CLF_DAYOFMONTH:
- /* both available: mmdd over ddd */
- case CLF_MONTH | CLF_DAYOFMONTH:
- case CLF_DAYOFMONTH:
- /* mmdd / dd over naked weekday */
- if (!(flags & CLF_ISO8601YEAR)) {
- flags &= ~CLF_ISO8601WEEK;
- }
- break;
- /* neither mmdd nor ddd available */
- case 0:
- /* but we have day of the week, which can be used */
- if (flags & CLF_DAYOFWEEK) {
- /* prefer week based calculation of julianday */
- flags |= CLF_ISO8601WEEK;
- }
- }
-
- /* YearWeekDay below YearMonthDay */
- if ((flags & CLF_ISO8601WEEK)
- && ((flags & (CLF_YEAR | CLF_DAYOFYEAR)) == (CLF_YEAR | CLF_DAYOFYEAR)
- || (flags & (CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH)) == (
- CLF_YEAR | CLF_DAYOFMONTH | CLF_MONTH))) {
- /* yy precedence below yyyy */
- if (!(flags & CLF_ISO8601CENTURY) && (flags & CLF_CENTURY)) {
- /* normally precedence of ISO is higher, but no century - so put it down */
- flags &= ~CLF_ISO8601WEEK;
- } else if (!(flags & CLF_ISO8601YEAR)) {
- /* yymmdd or yyddd over naked weekday */
- flags &= ~CLF_ISO8601WEEK;
- }
- }
-
- if (flags & CLF_YEAR) {
- if (yyYear < 100) {
- if (!(flags & CLF_CENTURY)) {
- if (yyYear >= dataPtr->yearOfCenturySwitch) {
- yyYear -= 100;
- }
- yyYear += dataPtr->currentYearCentury;
- } else {
- yyYear += info->dateCentury * 100;
- }
- }
- }
- if (flags & (CLF_ISO8601WEEK | CLF_ISO8601YEAR)) {
- if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_YEAR) {
- /* for calculations expected iso year */
- info->date.iso8601Year = yyYear;
- } else if (info->date.iso8601Year < 100) {
- if (!(flags & CLF_ISO8601CENTURY)) {
- if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) {
- info->date.iso8601Year -= 100;
- }
- info->date.iso8601Year += dataPtr->currentYearCentury;
- } else {
- info->date.iso8601Year += info->dateCentury * 100;
- }
- }
- if ((flags & (CLF_ISO8601YEAR | CLF_YEAR)) == CLF_ISO8601YEAR) {
- /* for calculations expected year (e. g. CLF_ISO8601WEEK not set) */
- yyYear = info->date.iso8601Year;
- }
- }
- }
- }
-
- /* if no time - reset time */
- if (!(flags & (CLF_TIME | CLF_LOCALSEC | CLF_POSIXSEC))) {
- info->flags |= CLF_ASSEMBLE_SECONDS;
- yydate.localSeconds = 0;
- }
-
- if (flags & CLF_TIME) {
- info->flags |= CLF_ASSEMBLE_SECONDS;
- yySecondOfDay = ToSeconds(yyHour, yyMinutes,
- yySeconds, yyMeridian);
- } else if (!(flags & (CLF_LOCALSEC | CLF_POSIXSEC))) {
- info->flags |= CLF_ASSEMBLE_SECONDS;
- yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY;
- }
- }
-
- /* tell caller which flags were set */
- info->flags |= flags;
-
- ret = TCL_OK;
- done:
- return ret;
-
- /* Error case reporting. */
-
- overflow:
- Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
- "integer value too large to represent", TCL_AUTO_LENGTH));
- Tcl_SetErrorCode(opts->interp, "CLOCK", "dateTooLarge", (char *)NULL);
- goto done;
-
- not_match:
-#if 1
- Tcl_SetObjResult(opts->interp, Tcl_NewStringObj(
- "input string does not match supplied format", TCL_AUTO_LENGTH));
-#else
- /* to debug where exactly scan breaks */
- Tcl_SetObjResult(opts->interp, Tcl_ObjPrintf(
- "input string \"%s\" does not match supplied format \"%s\","
- " locale \"%s\" - token \"%s\"",
- info->dateStart, HashEntry4FmtScn(fss)->key.string,
- TclGetString(opts->localeObj),
- tok && tok->tokWord.start ? tok->tokWord.start : "NULL"));
-#endif
- Tcl_SetErrorCode(opts->interp, "CLOCK", "badInputString", (char *)NULL);
- goto done;
-}
-
-#define FrmResultIsAllocated(dateFmt) \
- (dateFmt->resEnd - dateFmt->resMem > MIN_FMT_RESULT_BLOCK_ALLOC)
-
-static inline int
-FrmResultAllocate(
- DateFormat *dateFmt,
- int len)
-{
- int needed = dateFmt->output + len - dateFmt->resEnd;
- if (needed >= 0) { /* >= 0 - regards NTS zero */
- int newsize = dateFmt->resEnd - dateFmt->resMem
- + needed + MIN_FMT_RESULT_BLOCK_ALLOC * 2;
- char *newRes;
- /* differentiate between stack and memory */
- if (!FrmResultIsAllocated(dateFmt)) {
- newRes = (char *)Tcl_AttemptAlloc(newsize);
- if (newRes == NULL) {
- return TCL_ERROR;
- }
- memcpy(newRes, dateFmt->resMem, dateFmt->output - dateFmt->resMem);
- } else {
- newRes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, newsize);
- if (newRes == NULL) {
- return TCL_ERROR;
- }
- }
- dateFmt->output = newRes + (dateFmt->output - dateFmt->resMem);
- dateFmt->resMem = newRes;
- dateFmt->resEnd = newRes + newsize;
- }
- return TCL_OK;
-}
-
-static int
-ClockFmtToken_HourAMPM_Proc(
- TCL_UNUSED(ClockFmtScnCmdArgs *),
- TCL_UNUSED(DateFormat *),
- TCL_UNUSED(ClockFormatToken *),
- int *val)
-{
- *val = ((*val + SECONDS_PER_DAY - 3600) / 3600) % 12 + 1;
- return TCL_OK;
-}
-
-static int
-ClockFmtToken_AMPM_Proc(
- ClockFmtScnCmdArgs *opts,
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- int *val)
-{
- Tcl_Obj *mcObj;
- const char *s;
- Tcl_Size len;
-
- if (*val < (SECONDS_PER_DAY / 2)) {
- mcObj = ClockMCGet(opts, MCLIT_AM);
- } else {
- mcObj = ClockMCGet(opts, MCLIT_PM);
- }
- if (mcObj == NULL) {
- return TCL_ERROR;
- }
- s = TclGetStringFromObj(mcObj, &len);
- if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
- return TCL_ERROR;
- }
- memcpy(dateFmt->output, s, len + 1);
- if (*tok->tokWord.start == 'p') {
- len = Tcl_UtfToUpper(dateFmt->output);
- }
- dateFmt->output += len;
-
- return TCL_OK;
-}
-
-static int
-ClockFmtToken_StarDate_Proc(
- TCL_UNUSED(ClockFmtScnCmdArgs *),
- DateFormat *dateFmt,
- TCL_UNUSED(ClockFormatToken *),
- TCL_UNUSED(int *))
-{
- int fractYear;
- /* Get day of year, zero based */
- int v = dateFmt->date.dayOfYear - 1;
-
- /* Convert day of year to a fractional year */
- if (IsGregorianLeapYear(&dateFmt->date)) {
- fractYear = 1000 * v / 366;
- } else {
- fractYear = 1000 * v / 365;
- }
-
- /* Put together the StarDate as "Stardate %02d%03d.%1d" */
- if (FrmResultAllocate(dateFmt, 30) != TCL_OK) {
- return TCL_ERROR;
- }
- memcpy(dateFmt->output, "Stardate ", 9);
- dateFmt->output += 9;
- dateFmt->output = Clock_itoaw(dateFmt->output,
- dateFmt->date.year - RODDENBERRY, '0', 2);
- dateFmt->output = Clock_itoaw(dateFmt->output,
- fractYear, '0', 3);
- *dateFmt->output++ = '.';
- /* be sure positive after decimal point (note: clock-value can be negative) */
- v = dateFmt->date.secondOfDay / (SECONDS_PER_DAY / 10);
- if (v < 0) {
- v = 10 + v;
- }
- dateFmt->output = Clock_itoaw(dateFmt->output, v, '0', 1);
- return TCL_OK;
-}
-static int
-ClockFmtToken_WeekOfYear_Proc(
- TCL_UNUSED(ClockFmtScnCmdArgs *),
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- int *val)
-{
- int dow = dateFmt->date.dayOfWeek;
-
- if (*tok->tokWord.start == 'U') {
- if (dow == 7) {
- dow = 0;
- }
- dow++;
- }
- *val = (dateFmt->date.dayOfYear - dow + 7) / 7;
- return TCL_OK;
-}
-static int
-ClockFmtToken_JDN_Proc(
- TCL_UNUSED(ClockFmtScnCmdArgs *),
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- TCL_UNUSED(int *))
-{
- Tcl_WideInt intJD = dateFmt->date.julianDay;
- int fractJD;
-
- /* Convert to JDN parts (regarding start offset) and time fraction */
- fractJD = dateFmt->date.secondOfDay
- - (int)tok->map->offs; /* 0 for calendar or 43200 for astro JD */
- if (fractJD < 0) {
- intJD--;
- fractJD += SECONDS_PER_DAY;
- }
- if (fractJD && intJD < 0) { /* avoid jump over 0, by negative JD's */
- intJD++;
- if (intJD == 0) {
- /* -0.0 / -0.9 has zero integer part, so append "-" extra */
- if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {
- return TCL_ERROR;
- }
- *dateFmt->output++ = '-';
- }
- /* and inverse seconds of day, -0(75) -> -0.25 as float */
- fractJD = SECONDS_PER_DAY - fractJD;
- }
-
- /* 21 is max width of (negative) wide-int (rather smaller, but anyway a time fraction below) */
- if (FrmResultAllocate(dateFmt, 21) != TCL_OK) {
- return TCL_ERROR;
- }
- dateFmt->output = Clock_witoaw(dateFmt->output, intJD, '0', 1);
- /* simplest cases .0 and .5 */
- if (!fractJD || fractJD == (SECONDS_PER_DAY / 2)) {
- /* point + 0 or 5 */
- if (FrmResultAllocate(dateFmt, 1 + 1) != TCL_OK) {
- return TCL_ERROR;
- }
- *dateFmt->output++ = '.';
- *dateFmt->output++ = !fractJD ? '0' : '5';
- *dateFmt->output = '\0';
- return TCL_OK;
- } else {
- /* wrap the time fraction */
-#define JDN_MAX_PRECISION 8
-#define JDN_MAX_PRECBOUND 100000000 /* 10**JDN_MAX_PRECISION */
- char *p;
-
- /* to float (part after floating point, + 0.5 to round it up) */
- fractJD = (int)(
- (double)fractJD * JDN_MAX_PRECBOUND / SECONDS_PER_DAY + 0.5);
-
- /* point + integer (as time fraction after floating point) */
- if (FrmResultAllocate(dateFmt, 1 + JDN_MAX_PRECISION) != TCL_OK) {
- return TCL_ERROR;
- }
- *dateFmt->output++ = '.';
- p = Clock_itoaw(dateFmt->output, fractJD, '0', JDN_MAX_PRECISION);
-
- /* remove trailing zero's */
- dateFmt->output++;
- while (p > dateFmt->output && p[-1] == '0') {
- p--;
- }
- *p = '\0';
- dateFmt->output = p;
- }
- return TCL_OK;
-}
-static int
-ClockFmtToken_TimeZone_Proc(
- ClockFmtScnCmdArgs *opts,
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- TCL_UNUSED(int *))
-{
- if (*tok->tokWord.start == 'z') {
- int z = dateFmt->date.tzOffset;
- char sign = '+';
-
- if (z < 0) {
- z = -z;
- sign = '-';
- }
- if (FrmResultAllocate(dateFmt, 7) != TCL_OK) {
- return TCL_ERROR;
- }
- *dateFmt->output++ = sign;
- dateFmt->output = Clock_itoaw(dateFmt->output, z / 3600, '0', 2);
- z %= 3600;
- dateFmt->output = Clock_itoaw(dateFmt->output, z / 60, '0', 2);
- z %= 60;
- if (z != 0) {
- dateFmt->output = Clock_itoaw(dateFmt->output, z, '0', 2);
- }
- } else {
- Tcl_Obj * objPtr;
- const char *s;
- Tcl_Size len;
-
- /* convert seconds to local seconds to obtain tzName object */
- if (ConvertUTCToLocal(opts->dataPtr, opts->interp,
- &dateFmt->date, opts->timezoneObj,
- GREGORIAN_CHANGE_DATE) != TCL_OK) {
- return TCL_ERROR;
- }
- objPtr = dateFmt->date.tzName;
- s = TclGetStringFromObj(objPtr, &len);
- if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
- return TCL_ERROR;
- }
- memcpy(dateFmt->output, s, len + 1);
- dateFmt->output += len;
- }
- return TCL_OK;
-}
-
-static int
-ClockFmtToken_LocaleERA_Proc(
- ClockFmtScnCmdArgs *opts,
- DateFormat *dateFmt,
- TCL_UNUSED(ClockFormatToken *),
- TCL_UNUSED(int *))
-{
- Tcl_Obj *mcObj;
- const char *s;
- Tcl_Size len;
-
- if (dateFmt->date.isBce) {
- mcObj = ClockMCGet(opts, MCLIT_BCE);
- } else {
- mcObj = ClockMCGet(opts, MCLIT_CE);
- }
- if (mcObj == NULL) {
- return TCL_ERROR;
- }
- s = TclGetStringFromObj(mcObj, &len);
- if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
- return TCL_ERROR;
- }
-
- memcpy(dateFmt->output, s, len + 1);
- dateFmt->output += len;
- return TCL_OK;
-}
-
-static int
-ClockFmtToken_LocaleERAYear_Proc(
- ClockFmtScnCmdArgs *opts,
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- int *val)
-{
- Tcl_Size rowc;
- Tcl_Obj **rowv;
-
- if (dateFmt->localeEra == NULL) {
- Tcl_Obj *mcObj = ClockMCGet(opts, MCLIT_LOCALE_ERAS);
- if (mcObj == NULL) {
- return TCL_ERROR;
- }
- if (TclListObjGetElements(opts->interp, mcObj, &rowc, &rowv) != TCL_OK) {
- return TCL_ERROR;
- }
- if (rowc != 0) {
- dateFmt->localeEra = LookupLastTransition(opts->interp,
- dateFmt->date.localSeconds, rowc, rowv, NULL);
- }
- if (dateFmt->localeEra == NULL) {
- dateFmt->localeEra = (Tcl_Obj*)1;
- }
- }
-
- /* if no LOCALE_ERAS in catalog or era not found */
- if (dateFmt->localeEra == (Tcl_Obj*)1) {
- if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
- return TCL_ERROR;
- }
- if (*tok->tokWord.start == 'C') { /* %EC */
- *val = dateFmt->date.year / 100;
- dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
- } else { /* %Ey */
- *val = dateFmt->date.year % 100;
- dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
- }
- } else {
- Tcl_Obj *objPtr;
- const char *s;
- Tcl_Size len;
-
- if (*tok->tokWord.start == 'C') { /* %EC */
- if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 1,
- &objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- } else { /* %Ey */
- if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 2,
- &objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- if (Tcl_GetIntFromObj(opts->interp, objPtr, val) != TCL_OK) {
- return TCL_ERROR;
- }
- *val = dateFmt->date.year - *val;
- /* if year in locale numerals */
- if (*val >= 0 && *val < 100) {
- /* year as integer */
- Tcl_Obj * mcObj = ClockMCGet(opts, MCLIT_LOCALE_NUMERALS);
- if (mcObj == NULL) {
- return TCL_ERROR;
- }
- if (Tcl_ListObjIndex(opts->interp, mcObj, *val, &objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
- /* year as integer */
- if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
- return TCL_ERROR;
- }
- dateFmt->output = Clock_itoaw(dateFmt->output, *val, '0', 2);
- return TCL_OK;
- }
- }
- s = TclGetStringFromObj(objPtr, &len);
- if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
- return TCL_ERROR;
- }
- memcpy(dateFmt->output, s, len + 1);
- dateFmt->output += len;
- }
- return TCL_OK;
-}
-
-/*
- * Descriptors for the various fields in [clock format].
- */
-
-static const char *FmtSTokenMapIndex =
- "demNbByYCHMSIklpaAuwUVzgGjJsntQ";
-static const ClockFormatTokenMap FmtSTokenMap[] = {
- /* %d */
- {CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.dayOfMonth), NULL, NULL},
- /* %e */
- {CTOKT_INT, " ", 2, 0, 0, 0, offsetof(DateFormat, date.dayOfMonth), NULL, NULL},
- /* %m */
- {CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.month), NULL, NULL},
- /* %N */
- {CTOKT_INT, " ", 2, 0, 0, 0, offsetof(DateFormat, date.month), NULL, NULL},
- /* %b %h */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, offsetof(DateFormat, date.month),
- NULL, (void *)MCLIT_MONTHS_ABBREV},
- /* %B */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, offsetof(DateFormat, date.month),
- NULL, (void *)MCLIT_MONTHS_FULL},
- /* %y */
- {CTOKT_INT, "0", 2, 0, 0, 100, offsetof(DateFormat, date.year), NULL, NULL},
- /* %Y */
- {CTOKT_INT, "0", 4, 0, 0, 0, offsetof(DateFormat, date.year), NULL, NULL},
- /* %C */
- {CTOKT_INT, "0", 2, 0, 100, 0, offsetof(DateFormat, date.year), NULL, NULL},
- /* %H */
- {CTOKT_INT, "0", 2, 0, 3600, 24, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
- /* %M */
- {CTOKT_INT, "0", 2, 0, 60, 60, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
- /* %S */
- {CTOKT_INT, "0", 2, 0, 0, 60, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
- /* %I */
- {CTOKT_INT, "0", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.secondOfDay),
- ClockFmtToken_HourAMPM_Proc, NULL},
- /* %k */
- {CTOKT_INT, " ", 2, 0, 3600, 24, offsetof(DateFormat, date.secondOfDay), NULL, NULL},
- /* %l */
- {CTOKT_INT, " ", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.secondOfDay),
- ClockFmtToken_HourAMPM_Proc, NULL},
- /* %p %P */
- {CTOKT_INT, NULL, 0, 0, 0, 0, offsetof(DateFormat, date.secondOfDay),
- ClockFmtToken_AMPM_Proc, NULL},
- /* %a */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
- NULL, (void *)MCLIT_DAYS_OF_WEEK_ABBREV},
- /* %A */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
- NULL, (void *)MCLIT_DAYS_OF_WEEK_FULL},
- /* %u */
- {CTOKT_INT, " ", 1, 0, 0, 0, offsetof(DateFormat, date.dayOfWeek), NULL, NULL},
- /* %w */
- {CTOKT_INT, " ", 1, 0, 0, 7, offsetof(DateFormat, date.dayOfWeek), NULL, NULL},
- /* %U %W */
- {CTOKT_INT, "0", 2, CLFMT_CALC, 0, 0, offsetof(DateFormat, date.dayOfYear),
- ClockFmtToken_WeekOfYear_Proc, NULL},
- /* %V */
- {CTOKT_INT, "0", 2, 0, 0, 0, offsetof(DateFormat, date.iso8601Week), NULL, NULL},
- /* %z %Z */
- {CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
- ClockFmtToken_TimeZone_Proc, NULL},
- /* %g */
- {CTOKT_INT, "0", 2, 0, 0, 100, offsetof(DateFormat, date.iso8601Year), NULL, NULL},
- /* %G */
- {CTOKT_INT, "0", 4, 0, 0, 0, offsetof(DateFormat, date.iso8601Year), NULL, NULL},
- /* %j */
- {CTOKT_INT, "0", 3, 0, 0, 0, offsetof(DateFormat, date.dayOfYear), NULL, NULL},
- /* %J */
- {CTOKT_WIDE, "0", 7, 0, 0, 0, offsetof(DateFormat, date.julianDay), NULL, NULL},
- /* %s */
- {CTOKT_WIDE, "0", 1, 0, 0, 0, offsetof(DateFormat, date.seconds), NULL, NULL},
- /* %n */
- {CTOKT_CHAR, "\n", 0, 0, 0, 0, 0, NULL, NULL},
- /* %t */
- {CTOKT_CHAR, "\t", 0, 0, 0, 0, 0, NULL, NULL},
- /* %Q */
- {CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
- ClockFmtToken_StarDate_Proc, NULL},
-};
-static const char *FmtSTokenMapAliasIndex[2] = {
- "hPWZ",
- "bpUz"
-};
-
-static const char *FmtETokenMapIndex = "EJjys";
-static const ClockFormatTokenMap FmtETokenMap[] = {
- /* %EE */
- {CFMTT_PROC, NULL, 0, 0, 0, 0, 0,
- ClockFmtToken_LocaleERA_Proc, NULL},
- /* %EJ */
- {CFMTT_PROC, NULL, 0, 0, 0, 0, 0, /* calendar JDN starts at midnight */
- ClockFmtToken_JDN_Proc, NULL},
- /* %Ej */
- {CFMTT_PROC, NULL, 0, 0, 0, 0, (SECONDS_PER_DAY/2), /* astro JDN starts at noon */
- ClockFmtToken_JDN_Proc, NULL},
- /* %Ey %EC */
- {CTOKT_INT, NULL, 0, 0, 0, 0, offsetof(DateFormat, date.year),
- ClockFmtToken_LocaleERAYear_Proc, NULL},
- /* %Es */
- {CTOKT_WIDE, "0", 1, 0, 0, 0, offsetof(DateFormat, date.localSeconds), NULL, NULL},
-};
-static const char *FmtETokenMapAliasIndex[2] = {
- "C",
- "y"
-};
-
-static const char *FmtOTokenMapIndex = "dmyHIMSuw";
-static const ClockFormatTokenMap FmtOTokenMap[] = {
- /* %Od %Oe */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.dayOfMonth),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Om */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.month),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Oy */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.year),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OH %Ok */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 3600, 24, offsetof(DateFormat, date.secondOfDay),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OI %Ol */
- {CTOKT_INT, NULL, 0, CLFMT_CALC | CLFMT_LOCALE_INDX, 0, 0, offsetof(DateFormat, date.secondOfDay),
- ClockFmtToken_HourAMPM_Proc, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OM */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 60, 60, offsetof(DateFormat, date.secondOfDay),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %OS */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 60, offsetof(DateFormat, date.secondOfDay),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Ou */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, offsetof(DateFormat, date.dayOfWeek),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
- /* %Ow */
- {CTOKT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, offsetof(DateFormat, date.dayOfWeek),
- NULL, (void *)MCLIT_LOCALE_NUMERALS},
-};
-static const char *FmtOTokenMapAliasIndex[2] = {
- "ekl",
- "dHI"
-};
-
-static const ClockFormatTokenMap FmtWordTokenMap = {
- CTOKT_WORD, NULL, 0, 0, 0, 0, 0, NULL, NULL
-};
-
-/*
- *----------------------------------------------------------------------
- */
-ClockFmtScnStorage *
-ClockGetOrParseFmtFormat(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *formatObj) /* Format container */
-{
- ClockFmtScnStorage *fss;
-
- fss = Tcl_GetClockFrmScnFromObj(interp, formatObj);
- if (fss == NULL) {
- return NULL;
- }
-
- /* if format (fmtTok) already tokenized */
- if (fss->fmtTok != NULL) {
- return fss;
- }
-
- Tcl_MutexLock(&ClockFmtMutex);
-
- /* first time formatting - tokenize format */
- if (fss->fmtTok == NULL) {
- ClockFormatToken *tok, *fmtTok;
- unsigned tokCnt;
- const char *p, *e, *cp;
-
- e = p = HashEntry4FmtScn(fss)->key.string;
- e += strlen(p);
-
- /* estimate token count by % char and format length */
- fss->fmtTokC = EstimateTokenCount(p, e);
-
- fmtTok = tok = (ClockFormatToken *)Tcl_Alloc(sizeof(*tok) * fss->fmtTokC);
- memset(tok, 0, sizeof(*tok));
- tokCnt = 1;
- while (p < e) {
- switch (*p) {
- case '%': {
- const ClockFormatTokenMap *fmtMap = FmtSTokenMap;
- const char *mapIndex = FmtSTokenMapIndex;
- const char **aliasIndex = FmtSTokenMapAliasIndex;
-
- if (p + 1 >= e) {
- goto word_tok;
- }
- p++;
- /* try to find modifier: */
- switch (*p) {
- case '%':
- /* begin new word token - don't join with previous word token,
- * because current mapping should be "...%%..." -> "...%..." */
- tok->map = &FmtWordTokenMap;
- tok->tokWord.start = p;
- tok->tokWord.end = p + 1;
- AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
- tokCnt++;
- p++;
- continue;
- case 'E':
- fmtMap = FmtETokenMap,
- mapIndex = FmtETokenMapIndex,
- aliasIndex = FmtETokenMapAliasIndex;
- p++;
- break;
- case 'O':
- fmtMap = FmtOTokenMap,
- mapIndex = FmtOTokenMapIndex,
- aliasIndex = FmtOTokenMapAliasIndex;
- p++;
- break;
- }
- /* search direct index */
- cp = strchr(mapIndex, *p);
- if (!cp || *cp == '\0') {
- /* search wrapper index (multiple chars for same token) */
- cp = strchr(aliasIndex[0], *p);
- if (!cp || *cp == '\0') {
- p--;
- if (fmtMap != FmtSTokenMap) {
- p--;
- }
- goto word_tok;
- }
- cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]);
- if (!cp || *cp == '\0') { /* unexpected, but ... */
-#ifdef DEBUG
- Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p);
-#endif
- p--;
- if (fmtMap != FmtSTokenMap) {
- p--;
- }
- goto word_tok;
- }
- }
- tok->map = &fmtMap[cp - mapIndex];
- tok->tokWord.start = p;
- /* next token */
- AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
- tokCnt++;
- p++;
- continue;
- }
- default:
- word_tok:
- {
- /* try continue with previous word token */
- ClockFormatToken *wordTok = tok - 1;
-
- if (wordTok < fmtTok || wordTok->map != &FmtWordTokenMap) {
- /* start with new word token */
- wordTok = tok;
- wordTok->tokWord.start = p;
- wordTok->map = &FmtWordTokenMap;
- }
- do {
- p = Tcl_UtfNext(p);
- } while (p < e && *p != '%');
- wordTok->tokWord.end = p;
-
- if (wordTok == tok) {
- AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *);
- tokCnt++;
- }
- }
- break;
- }
- }
-
- /* correct count of real used tokens and free mem if desired
- * (1 is acceptable delta to prevent memory fragmentation) */
- if (fss->fmtTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) {
- if ((tok = (ClockFormatToken *)
- Tcl_AttemptRealloc(fmtTok, tokCnt * sizeof(*tok))) != NULL) {
- fmtTok = tok;
- }
- }
-
- /* now we're ready - assign now to storage (note the threaded race condition) */
- fss->fmtTok = fmtTok;
- fss->fmtTokC = tokCnt;
- }
-
- Tcl_MutexUnlock(&ClockFmtMutex);
- return fss;
-}
-
-/*
- *----------------------------------------------------------------------
- */
-int
-ClockFormat(
- DateFormat *dateFmt, /* Date fields used for parsing & converting */
- ClockFmtScnCmdArgs *opts) /* Command options */
-{
- ClockFmtScnStorage *fss;
- ClockFormatToken *tok;
- const ClockFormatTokenMap *map;
- char resMem[MIN_FMT_RESULT_BLOCK_ALLOC];
-
- /* get localized format */
- if (ClockLocalizeFormat(opts) == NULL) {
- return TCL_ERROR;
- }
-
- if (!(fss = ClockGetOrParseFmtFormat(opts->interp, opts->formatObj))
- || !(tok = fss->fmtTok)) {
- return TCL_ERROR;
- }
-
- /* result container object */
- dateFmt->resMem = resMem;
- dateFmt->resEnd = dateFmt->resMem + sizeof(resMem);
- if (fss->fmtMinAlloc > sizeof(resMem)) {
- dateFmt->resMem = (char *)Tcl_AttemptAlloc(fss->fmtMinAlloc);
- if (dateFmt->resMem == NULL) {
- return TCL_ERROR;
- }
- dateFmt->resEnd = dateFmt->resMem + fss->fmtMinAlloc;
- }
- dateFmt->output = dateFmt->resMem;
- *dateFmt->output = '\0';
-
- /* do format each token */
- for (; tok->map != NULL; tok++) {
- map = tok->map;
- switch (map->type) {
- case CTOKT_INT: {
- int val = *IntFieldAt(dateFmt, map->offs);
-
- if (map->fmtproc == NULL) {
- if (map->flags & CLFMT_DECR) {
- val--;
- }
- if (map->flags & CLFMT_INCR) {
- val++;
- }
- if (map->divider) {
- val /= map->divider;
- }
- if (map->divmod) {
- val %= map->divmod;
- }
- } else {
- if (map->fmtproc(opts, dateFmt, tok, &val) != TCL_OK) {
- goto done;
- }
- /* if not calculate only (output inside fmtproc) */
- if (!(map->flags & CLFMT_CALC)) {
- continue;
- }
- }
- if (!(map->flags & CLFMT_LOCALE_INDX)) {
- if (FrmResultAllocate(dateFmt, 11) != TCL_OK) {
- goto error;
- }
- if (map->width) {
- dateFmt->output = Clock_itoaw(
- dateFmt->output, val, *map->tostr, map->width);
- } else {
- dateFmt->output += sprintf(dateFmt->output, map->tostr, val);
- }
- } else {
- const char *s;
- Tcl_Obj * mcObj = ClockMCGet(opts, PTR2INT(map->data) /* mcKey */);
-
- if (mcObj == NULL) {
- goto error;
- }
- if (Tcl_ListObjIndex(opts->interp, mcObj, val, &mcObj) != TCL_OK
- || mcObj == NULL) {
- goto error;
- }
- s = TclGetString(mcObj);
- if (FrmResultAllocate(dateFmt, mcObj->length) != TCL_OK) {
- goto error;
- }
- memcpy(dateFmt->output, s, mcObj->length + 1);
- dateFmt->output += mcObj->length;
- }
- break;
- }
- case CTOKT_WIDE: {
- Tcl_WideInt val = *WideFieldAt(dateFmt, map->offs);
-
- if (FrmResultAllocate(dateFmt, 21) != TCL_OK) {
- goto error;
- }
- if (map->width) {
- dateFmt->output = Clock_witoaw(dateFmt->output, val, *map->tostr, map->width);
- } else {
- dateFmt->output += sprintf(dateFmt->output, map->tostr, val);
- }
- break;
- }
- case CTOKT_CHAR:
- if (FrmResultAllocate(dateFmt, 1) != TCL_OK) {
- goto error;
- }
- *dateFmt->output++ = *map->tostr;
- break;
- case CFMTT_PROC:
- if (map->fmtproc(opts, dateFmt, tok, NULL) != TCL_OK) {
- goto error;
- }
- break;
- case CTOKT_WORD: {
- Tcl_Size len = tok->tokWord.end - tok->tokWord.start;
-
- if (FrmResultAllocate(dateFmt, len) != TCL_OK) {
- goto error;
- }
- if (len == 1) {
- *dateFmt->output++ = *tok->tokWord.start;
- } else {
- memcpy(dateFmt->output, tok->tokWord.start, len);
- dateFmt->output += len;
- }
- break;
- }
- }
- }
- goto done;
-
- error:
- if (dateFmt->resMem != resMem) {
- Tcl_Free(dateFmt->resMem);
- }
- dateFmt->resMem = NULL;
-
- done:
- if (dateFmt->resMem) {
- size_t size;
- Tcl_Obj *result;
-
- TclNewObj(result);
- result->length = dateFmt->output - dateFmt->resMem;
- size = result->length + 1;
- if (dateFmt->resMem == resMem) {
- result->bytes = (char *)Tcl_AttemptAlloc(size);
- if (result->bytes == NULL) {
- return TCL_ERROR;
- }
- memcpy(result->bytes, dateFmt->resMem, size);
- } else if ((dateFmt->resEnd - dateFmt->resMem) / size > MAX_FMT_RESULT_THRESHOLD) {
- result->bytes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, size);
- if (result->bytes == NULL) {
- result->bytes = dateFmt->resMem;
- }
- } else {
- result->bytes = dateFmt->resMem;
- }
- /* save last used buffer length */
- if (dateFmt->resMem != resMem
- && fss->fmtMinAlloc < size + MIN_FMT_RESULT_BLOCK_DELTA) {
- fss->fmtMinAlloc = size + MIN_FMT_RESULT_BLOCK_DELTA;
- }
- result->bytes[result->length] = '\0';
- Tcl_SetObjResult(opts->interp, result);
- return TCL_OK;
- }
-
- return TCL_ERROR;
-}
-
-
-void
-ClockFrmScnClearCaches(void)
-{
- Tcl_MutexLock(&ClockFmtMutex);
- /* clear caches ... */
- Tcl_MutexUnlock(&ClockFmtMutex);
-}
-
-void
-ClockFrmScnFinalize(void)
-{
- if (!initialized) {
- return;
- }
- Tcl_MutexLock(&ClockFmtMutex);
-#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
- /* clear GC */
- ClockFmtScnStorage_GC.stackPtr = NULL;
- ClockFmtScnStorage_GC.stackBound = NULL;
- ClockFmtScnStorage_GC.count = 0;
-#endif
- if (initialized) {
- initialized = 0;
- Tcl_DeleteHashTable(&FmtScnHashTable);
- }
- Tcl_MutexUnlock(&ClockFmtMutex);
- Tcl_MutexFinalize(&ClockFmtMutex);
-}
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
Index: generic/tclCmdAH.c
==================================================================
--- generic/tclCmdAH.c
+++ generic/tclCmdAH.c
@@ -1,18 +1,29 @@
/*
- * tclCmdAH.c --
- *
- * This file contains the top-level command routines for most of the Tcl
- * built-in commands whose names begin with the letters A to H.
- *
* Copyright © 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"
@@ -634,11 +645,11 @@
/*
* Convert the string to a byte array in 'ds'
*/
- stringPtr = TclGetStringFromObj(data, &length);
+ 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) {
@@ -2064,11 +2075,11 @@
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- res = Tcl_FSSplitPath(objv[1], (Tcl_Size *)NULL);
+ 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",
@@ -2805,12 +2816,13 @@
*/
for (i=0 ; ivCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
- if (statePtr->vCopyList[i] == NULL) {
+ 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]);
@@ -2830,23 +2842,29 @@
}
TclListObjGetElements(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
/* Values */
- if (TclObjTypeHasProc(objv[2+i*2],indexProc)) {
- /* Special case for AbstractList */
+ 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 */
- statePtr->argcList[i] = TclObjTypeLength(statePtr->aCopyList[i]);
+ 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 {
- /* List values */
- statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (statePtr->aCopyList[i] == NULL) {
+ 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]);
@@ -2979,18 +2997,20 @@
int i;
Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; inumLists ; i++) {
- int isAbstractList =
- TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL;
-
+ int status;
+ int hasindexinterface = TclObjectHasInterface(
+ statePtr->aCopyList[i], list, index);
for (v=0 ; vvarcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
- if (isAbstractList) {
- if (TclObjTypeIndex(interp, statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) {
+ 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;
Index: generic/tclCmdIL.c
==================================================================
--- generic/tclCmdIL.c
+++ generic/tclCmdIL.c
@@ -1,13 +1,6 @@
/*
- * 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).
- *
* 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.
@@ -15,10 +8,28 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
#include
@@ -565,11 +576,11 @@
* 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 = TclGetStringFromObj(procPtr->bodyPtr, &numBytes);
+ bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes);
Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes));
return TCL_OK;
}
/*
@@ -2156,12 +2167,12 @@
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
- int isAbstractList = 0;
- Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
+ int status;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs = NULL;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
@@ -2169,64 +2180,104 @@
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
- if (TclObjTypeHasProc(objv[1], getElementsProc)) {
- listLen = TclObjTypeLength(objv[1]);
- isAbstractList = (listLen ? 1 : 0);
- if (listLen > 1 && TclObjTypeGetElements(interp, objv[1],
- &listLen, &elemPtrs) != TCL_OK) {
+ 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) {
+ &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 (!isAbstractList) {
- Tcl_SetObjResult(interp, elemPtrs[0]);
- } else {
- Tcl_Obj *elemObj;
-
- if (TclObjTypeIndex(interp, objv[1], 0, &elemObj) != TCL_OK) {
+ 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, elemObj);
+ 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)TclGetStringFromObj(joinObjPtr, &length);
+ (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);
- 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]);
+ 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);
@@ -2260,11 +2311,11 @@
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
Tcl_Size listObjc; /* The length of the list. */
Tcl_Size origListObjc; /* Original length */
- int i;
+ int i, status;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
@@ -2324,26 +2375,27 @@
}
Tcl_DecrRefCount(emptyObj);
}
if (listObjc > 0) {
- Tcl_Obj *resultObjPtr = NULL;
+ Tcl_Obj *resultPtr = NULL;
Tcl_Size fromIdx = origListObjc - listObjc;
Tcl_Size toIdx = origListObjc - 1;
- if (TclObjTypeHasProc(listPtr, sliceProc)) {
- if (TclObjTypeSlice(
- interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) {
+ if (TclObjectHasInterface(listPtr, list, range)) {
+ TclObjectDispatchNoDefault(interp, status, listPtr, list, range,
+ interp, listPtr, fromIdx, toIdx, &resultPtr);
+ if (status != TCL_OK) {
return TCL_ERROR;
}
} else {
- resultObjPtr = TclListObjRange(
- interp, listPtr, origListObjc - listObjc, origListObjc - 1);
- if (resultObjPtr == NULL) {
- return TCL_ERROR;
+ status = TclListObjRange(interp, listPtr,
+ origListObjc - listObjc, origListObjc - 1, &resultPtr);
+ if (status != TCL_OK || resultPtr == NULL) {
+ return status;
}
}
- Tcl_SetObjResult(interp, resultObjPtr);
+ Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
@@ -2462,11 +2514,14 @@
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
- listPtr = TclListObjCopy(NULL, listPtr);
+ listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
+ if (!listPtr) {
+ return TCL_ERROR;
+ }
copied = 1;
}
if ((objc == 4) && (index == len)) {
/*
@@ -2607,11 +2662,11 @@
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
Tcl_Size listLen;
- int copied = 0, result;
+ int copied = 0, result, status;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?");
@@ -2659,16 +2714,18 @@
Tcl_SetObjResult(interp, elemPtr);
Tcl_DecrRefCount(elemPtr);
/*
* Second, remove the element.
- * TclLsetFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
- listPtr = TclListObjCopy(NULL, listPtr);
+ 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) {
@@ -2676,24 +2733,15 @@
}
return result;
}
} else {
Tcl_Obj *newListPtr;
- Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(listPtr, setElementProc);
- if (proc) {
- newListPtr = proc(interp, listPtr, objc-2, objv+2, NULL);
- } else {
- newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL);
- }
- if (newListPtr == NULL) {
- if (copied) {
- Tcl_DecrRefCount(listPtr);
- }
- return TCL_ERROR;
+ status = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL, &newListPtr);
+ if (status != TCL_OK || newListPtr == NULL) {
+ return status;
} else {
listPtr = newListPtr;
- TclUndoRefCount(listPtr);
}
}
stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG);
if (stored == NULL) {
@@ -2726,12 +2774,12 @@
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
- int result;
- Tcl_Size listLen, first, last;
+ 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;
}
@@ -2738,36 +2786,58 @@
result = TclListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
return result;
}
- 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;
- }
-
- if (TclObjTypeHasProc(objv[1], sliceProc)) {
- Tcl_Obj *resultObj;
- int status = TclObjTypeSlice(interp, objv[1], first, last, &resultObj);
- if (status == TCL_OK) {
- Tcl_SetObjResult(interp, resultObj);
- } else {
- return TCL_ERROR;
- }
- } else {
- Tcl_Obj *resultObj = TclListObjRange(interp, objv[1], first, last);
- if (resultObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, resultObj);
+ 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;
}
/*
@@ -2854,11 +2924,15 @@
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
- listObj = TclListObjCopy(NULL, 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++) {
@@ -2939,12 +3013,11 @@
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
- Tcl_WideInt elementCount, i;
- Tcl_Size totalElems;
+ Tcl_Size elementCount, i, totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
* lrepeat count ?value ...?
@@ -2952,16 +3025,16 @@
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?");
return TCL_ERROR;
}
- if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) {
+ if (TCL_OK != Tcl_GetSizeIntFromObj(interp, objv[1], &elementCount)) {
return TCL_ERROR;
}
if (elementCount < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount));
+ "bad count \"%" TCL_SIZE_MODIFIER "d\": must be integer >= 0", elementCount));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG",
(char *)NULL);
return TCL_ERROR;
}
@@ -3094,11 +3167,11 @@
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
- numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */
+ numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
/*
@@ -3106,11 +3179,14 @@
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
- listPtr = TclListObjCopy(NULL, 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
@@ -3163,22 +3239,25 @@
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
- /*
- * Handle AbstractList special case - do not shimmer into a list, if it
- * supports a private Reverse function, just to reverse it.
- */
- if (TclObjTypeHasProc(objv[1], reverseProc)) {
- Tcl_Obj *resultObj;
-
- if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) {
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- }
- } /* end Abstract List */
+ 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;
}
@@ -3261,18 +3340,18 @@
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 groupOffset, lower, upper;
+ Tcl_Size groupSize, groupOffset, lower, upper;
int allocatedIndexVector = 0;
int isIncreasing;
- Tcl_WideInt patWide, objWide, wide, groupSize;
+ Tcl_WideInt patWide, objWide, wide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
- Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL;
+ 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",
@@ -3298,10 +3377,11 @@
mode = GLOB;
dataType = ASCII;
isIncreasing = 1;
allMatches = 0;
inlineReturn = 0;
+ itemPtr = NULL;
returnSubindices = 0;
negatedMatch = 0;
bisect = 0;
listPtr = NULL;
startPtr = NULL;
@@ -3566,11 +3646,12 @@
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
- result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
+ subjectPtr = objv[objc-2];
+ result = Tcl_ListObjLength(interp, subjectPtr, &listc);
if (result != TCL_OK) {
goto done;
}
/*
@@ -3620,29 +3701,31 @@
/*
* Get the user-specified start offset.
*/
if (startPtr) {
- result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
+ 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, we just return a
+ * 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 (start >= listc) {
+ if (Tcl_LengthIsFinite(listc) && start >= listc) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
TclNewIntObj(itemPtr, -1);
Tcl_SetObjResult(interp, itemPtr);
+ itemPtr = NULL;
}
goto done;
}
/*
@@ -3658,41 +3741,37 @@
patternBytes = NULL;
if (mode == EXACT || mode == SORTED) {
switch (dataType) {
case ASCII:
case DICTIONARY:
- patternBytes = TclGetStringFromObj(patObj, &length);
+ patternBytes = Tcl_GetStringFromObj(patObj, &length);
break;
case INTEGER:
result = TclGetWideIntFromObj(interp, patObj, &patWide);
if (result != TCL_OK) {
goto done;
}
/*
- * List representation might have been shimmered; restore it. [Bug
- * 1844789]
+ * [Bug 1844789], "lsearch -exact -integer ..." crashes, was
+ * previously fixed at this point.
*/
-
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
case REAL:
result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
if (result != TCL_OK) {
goto done;
}
/*
- * List representation might have been shimmered; restore it. [Bug
- * 1844789]
+ * [Bug 1844789], "lsearch -exact -integer ..." crashes, was
+ * previously fixed at this point.
*/
-
- TclListObjGetElements(NULL, objv[objc - 2], &listc, &listv);
break;
}
} else {
- patternBytes = TclGetStringFromObj(patObj, &length);
+ 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.
@@ -3700,10 +3779,11 @@
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.
@@ -3712,27 +3792,61 @@
/*
* With -stride, lower, upper and i are kept as multiples of groupSize.
*/
lower = start - groupSize;
- upper = listc;
- itemPtr = NULL;
- while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
- i = (lower + upper)/2;
+ 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;
-
- Tcl_BounceRefCount(itemPtr);
- itemPtr = NULL;
-
+ 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) {
- itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
+ item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
- } else {
- itemPtr = listv[i+groupOffset];
+ /* 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);
@@ -3766,10 +3880,12 @@
} 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.
@@ -3792,18 +3908,26 @@
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;
@@ -3817,34 +3941,39 @@
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
- for (i = start; i < listc; i += groupSize) {
+ for (i = start; listc < 0 || i < listc; i += groupSize) {
match = 0;
- Tcl_BounceRefCount(itemPtr);
- itemPtr = NULL;
-
+ result = Tcl_ListObjIndex(interp, subjectPtr, i+groupOffset, &itemPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ Tcl_IncrRefCount(itemPtr);
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
+ item2Ptr = SelectObjFromSublist(itemPtr, &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
result = sortInfo.resultCode;
goto done;
}
- } else {
- itemPtr = listv[i+groupOffset];
+ /* 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 = TclGetStringFromObj(itemPtr, &elemLen);
+ bytes = Tcl_GetStringFromObj(itemPtr, &elemLen);
if (length == elemLen) {
/*
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
@@ -3910,53 +4039,73 @@
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) {
/*
- * Note that these appends are not expected to fail.
+ * These append operations are expected to not fail.
*/
+ Tcl_DecrRefCount(itemPtr);
+ itemPtr = NULL;
if (returnSubindices && (sortInfo.indexc != 0)) {
- Tcl_BounceRefCount(itemPtr);
- itemPtr = SelectObjFromSublist(listv[i+groupOffset],
- &sortInfo);
- Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ 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_ListObjReplace(interp, listPtr, LIST_MAX, 0,
- groupSize, &listv[i]);
+ 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 {
- Tcl_BounceRefCount(itemPtr);
- itemPtr = listv[i];
+ 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 1) {
- Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
+ 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 {
- Tcl_SetObjResult(interp, listv[index]);
+ 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:
- /* potential lingering abstract list element */
- Tcl_BounceRefCount(itemPtr);
-
+ if (itemPtr != NULL) {
+ Tcl_DecrRefCount(itemPtr);
+ }
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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,
+ "listVar ?index? ?index ...? value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the list variable's value.
+ */
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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;
+}
/*
*----------------------------------------------------------------------
*
* SequenceIdentifyArgument --
@@ -4382,16 +4637,20 @@
}
/*
* Success! Now lets create the series object.
*/
- status = TclNewArithSeriesObj(interp, &arithSeriesPtr,
- useDoubles, start, end, step, elementCount);
+ arithSeriesPtr = TclNewArithSeriesObj(interp,
+ useDoubles, start, end, step, elementCount);
- if (status == TCL_OK) {
+ 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]) {
@@ -4403,103 +4662,10 @@
Tcl_DecrRefCount(zero);
Tcl_DecrRefCount(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(void *),
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument values. */
-{
- Tcl_Obj *listPtr; /* Pointer to the list being altered. */
- Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
-
- /*
- * Check parameter count.
- */
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "listVar ?index? ?index ...? value");
- return TCL_ERROR;
- }
-
- /*
- * Look up the list variable's value.
- */
-
- listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
- if (listPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * 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 {
- if (TclObjTypeHasProc(listPtr, setElementProc)) {
- finalValuePtr = TclObjTypeSetElement(interp, listPtr,
- objc-3, objv+2, objv[objc-1]);
- if (finalValuePtr) {
- Tcl_IncrRefCount(finalValuePtr);
- }
- } else {
- finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
- objv[objc-1]);
- }
- }
-
- /*
- * If substitution has failed, bail out.
- */
-
- if (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);
- Tcl_DecrRefCount(finalValuePtr);
- 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 --
@@ -4524,12 +4690,12 @@
Tcl_Obj *const objv[]) /* Argument values. */
{
int indices, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, allocatedIndexVector = 0;
- Tcl_Size j, idx, groupOffset, length;
- Tcl_WideInt wide, groupSize;
+ 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. */
@@ -4741,11 +4907,11 @@
* have the representation of the list being sorted shimmered out from
* underneath our feet. Take a copy (cheap) to prevent this. [Bug
* 1675116]
*/
- listObj = TclListObjCopy(interp, listObj);
+ listObj = TclDuplicatePureObj(interp ,listObj, tclListTypePtr);
if (listObj == NULL) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
@@ -4766,13 +4932,14 @@
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
- if (TclObjTypeHasProc(objv[1], getElementsProc)) {
- sortInfo.resultCode =
- TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs);
+ 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) {
@@ -4961,11 +5128,11 @@
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
ListObjGetRep(resultPtr, &listRep);
newArray = ListRepElementsBase(&listRep);
if (group) {
- for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
+ 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;
@@ -5089,17 +5256,20 @@
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
- numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */
+ numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
if (Tcl_IsShared(listPtr)) {
- listPtr = TclListObjCopy(NULL, listPtr);
+ listPtr = TclDuplicatePureObj(interp, listPtr, tclListTypePtr);
+ if (!listPtr) {
+ return TCL_ERROR;
+ }
createdNewObj = 1;
} else {
createdNewObj = 0;
}
Index: generic/tclCmdMZ.c
==================================================================
--- generic/tclCmdMZ.c
+++ generic/tclCmdMZ.c
@@ -1,13 +1,6 @@
/*
- * 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).
- *
* 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.
@@ -14,18 +7,37 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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);
@@ -1187,17 +1199,17 @@
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
- splitChars = TclGetStringFromObj(objv[2], &splitCharLen);
+ splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
- stringPtr = TclGetStringFromObj(objv[1], &stringLen);
+ stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen);
end = stringPtr + stringLen;
TclNewObj(listPtr);
if (stringLen == 0) {
/*
@@ -1312,11 +1324,11 @@
{
Tcl_Size start = TCL_INDEX_START;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "needleString haystackString ?startIndex?");
+ "needleString haystackString ?startIndex?");
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1;
@@ -1403,43 +1415,55 @@
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
return TCL_ERROR;
}
- /*
- * 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;
+ 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;
+ }
}
/*
*----------------------------------------------------------------------
*
@@ -1608,16 +1632,16 @@
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if (!TclHasInternalRep(objPtr, &tclBooleanType)
+ if (!TclHasInternalRep(objPtr, tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
- string1 = TclGetStringFromObj(objPtr, &length1);
+ string1 = Tcl_GetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
} else if ((objPtr->internalRep.wideValue != 0)
? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) {
result = 0;
@@ -1642,11 +1666,11 @@
const char *elemStart, *nextElem;
Tcl_Size lenRemain, elemSize;
const char *p;
- string1 = TclGetStringFromObj(objPtr, &length1);
+ 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,
@@ -1677,16 +1701,16 @@
}
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
- if (TclHasInternalRep(objPtr, &tclDoubleType) ||
- TclHasInternalRep(objPtr, &tclIntType) ||
- TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType) ||
+ TclHasInternalRep(objPtr, tclIntType) ||
+ TclHasInternalRep(objPtr, tclBignumType)) {
break;
}
- string1 = TclGetStringFromObj(objPtr, &length1);
+ string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
@@ -1708,15 +1732,15 @@
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
case STR_IS_ENTIER:
- if (TclHasInternalRep(objPtr, &tclIntType) ||
- TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclIntType) ||
+ TclHasInternalRep(objPtr, tclBignumType)) {
break;
}
- string1 = TclGetStringFromObj(objPtr, &length1);
+ string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
@@ -1754,11 +1778,11 @@
case STR_IS_WIDE:
if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
- string1 = TclGetStringFromObj(objPtr, &length1);
+ string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
@@ -1823,11 +1847,11 @@
const char *elemStart, *nextElem;
Tcl_Size lenRemain;
Tcl_Size elemSize;
const char *p;
- string1 = TclGetStringFromObj(objPtr, &length1);
+ 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,
@@ -1878,11 +1902,11 @@
chcomp = UniCharIsHexDigit;
break;
}
if (chcomp != NULL) {
- string1 = TclGetStringFromObj(objPtr, &length1);
+ string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
goto str_is_done;
@@ -1964,11 +1988,11 @@
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
- const char *string = TclGetStringFromObj(objv[1], &length2);
+ const char *string = Tcl_GetStringFromObj(objv[1], &length2);
if ((length2 > 1) &&
strncmp(string, "-nocase", length2) == 0) {
nocase = 1;
} else {
@@ -1984,11 +2008,11 @@
* 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], &tclDictType)) {
+ && TclHasInternalRep(objv[objc-2], tclDictTypePtr)) {
Tcl_Size i;
int done;
Tcl_DictSearch search;
/*
@@ -2237,11 +2261,11 @@
return TCL_ERROR;
}
if (objc == 4) {
Tcl_Size length;
- const char *string = TclGetStringFromObj(objv[1], &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(
@@ -2525,15 +2549,15 @@
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
- next = ((p > string) ? (p - 1) : p);
+ next = p > string ? p - 1 : p;
do {
next += delta;
- ch = *next;
delta = 1;
+ ch = *next;
} while (next + delta < p);
p = next;
}
if (cur != index) {
cur += 1;
@@ -2647,11 +2671,11 @@
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
- string2 = TclGetStringFromObj(objv[i], &length);
+ 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) {
@@ -2750,11 +2774,11 @@
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
for (i = 1; i < objc-2; i++) {
- string = TclGetStringFromObj(objv[i], &length);
+ 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) {
@@ -2891,11 +2915,11 @@
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToLower(TclGetString(resultPtr));
@@ -2926,11 +2950,11 @@
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ 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);
@@ -2976,11 +3000,11 @@
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
@@ -3011,11 +3035,11 @@
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ 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);
@@ -3061,11 +3085,11 @@
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
@@ -3096,11 +3120,11 @@
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
- string1 = TclGetStringFromObj(objv[1], &length1);
+ 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);
@@ -3141,19 +3165,19 @@
{
const char *string1, *string2;
Tcl_Size triml, trimr, length1, length2;
if (objc == 3) {
- string2 = TclGetStringFromObj(objv[2], &length2);
+ 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 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
triml = TclTrim(string1, length1, string2, length2, &trimr);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
@@ -3189,19 +3213,19 @@
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
- string2 = TclGetStringFromObj(objv[2], &length2);
+ 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 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
trim = TclTrimLeft(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim));
return TCL_OK;
@@ -3236,19 +3260,19 @@
const char *string1, *string2;
int trim;
Tcl_Size length1, length2;
if (objc == 3) {
- string2 = TclGetStringFromObj(objv[2], &length2);
+ 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 = TclGetStringFromObj(objv[1], &length1);
+ string1 = Tcl_GetStringFromObj(objv[1], &length1);
trim = TclTrimRight(string1, length1, string2, length2);
Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim));
return TCL_OK;
@@ -3661,11 +3685,11 @@
for (i = 0; i < objc; i += 2) {
/*
* See if the pattern matches the string.
*/
- pattern = TclGetStringFromObj(objv[i], &patternLength);
+ pattern = Tcl_GetStringFromObj(objv[i], &patternLength);
if ((i == objc - 2) && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
Tcl_Obj *emptyObj = NULL;
Index: generic/tclCompCmds.c
==================================================================
--- generic/tclCompCmds.c
+++ generic/tclCompCmds.c
@@ -1,20 +1,31 @@
/*
- * tclCompCmds.c --
- *
- * This file contains compilation procedures that compile various Tcl
- * commands into a sequence of instructions ("bytecodes").
- *
* 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
/*
@@ -891,11 +902,11 @@
Tcl_Size len, slen;
TclListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
- bytes = TclGetStringFromObj(objPtr, &slen);
+ bytes = Tcl_GetStringFromObj(objPtr, &slen);
PushLiteral(envPtr, bytes, slen);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
@@ -1406,11 +1417,11 @@
/*
* We did! Excellent. The "verifyDict" is to do type forcing.
*/
- bytes = TclGetStringFromObj(dictObj, &len);
+ bytes = Tcl_GetStringFromObj(dictObj, &len);
PushLiteral(envPtr, bytes, len);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
Tcl_DecrRefCount(dictObj);
return TCL_OK;
@@ -2847,11 +2858,11 @@
const char *bytes;
int varIndex;
Tcl_Size length;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
- bytes = TclGetStringFromObj(varNameObj, &length);
+ bytes = Tcl_GetStringFromObj(varNameObj, &length);
varIndex = LocalScalar(bytes, length, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
@@ -3283,11 +3294,11 @@
/*
* Not an error, always a constant result, so just push the result as a
* literal. Job done.
*/
- bytes = TclGetStringFromObj(tmpObj, &len);
+ bytes = Tcl_GetStringFromObj(tmpObj, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
checkForStringConcatCase:
@@ -3354,11 +3365,11 @@
if (*bytes == '%') {
Tcl_AppendToObj(tmpObj, start, bytes - start);
if (*++bytes == '%') {
Tcl_AppendToObj(tmpObj, "%", 1);
} else {
- const char *b = TclGetStringFromObj(tmpObj, &len);
+ const char *b = Tcl_GetStringFromObj(tmpObj, &len);
/*
* If there is a non-empty literal from the format string,
* push it and reset.
*/
@@ -3388,11 +3399,11 @@
/*
* Handle the case of a trailing literal.
*/
Tcl_AppendToObj(tmpObj, start, bytes - start);
- bytes = TclGetStringFromObj(tmpObj, &len);
+ bytes = Tcl_GetStringFromObj(tmpObj, &len);
if (len > 0) {
PushLiteral(envPtr, bytes, len);
i++;
}
Tcl_DecrRefCount(tmpObj);
Index: generic/tclCompCmdsGR.c
==================================================================
--- generic/tclCompCmdsGR.c
+++ generic/tclCompCmdsGR.c
@@ -1,21 +1,32 @@
/*
- * 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").
- *
* 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
/*
@@ -39,11 +50,11 @@
* 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 *index.
+ * to *indexPtr.
*
*----------------------------------------------------------------------
*/
int
@@ -1409,10 +1420,17 @@
{
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 */
@@ -2170,11 +2188,11 @@
/*
* Next, higher-level checks. Is the RE a very simple glob? Is the
* replacement "simple"?
*/
- bytes = TclGetStringFromObj(patternObj, &len);
+ bytes = Tcl_GetStringFromObj(patternObj, &len);
if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified)
!= TCL_OK || exact || quantified) {
goto done;
}
bytes = Tcl_DStringValue(&pattern);
@@ -2218,11 +2236,11 @@
*/
result = TCL_OK;
bytes = Tcl_DStringValue(&pattern) + 1;
PushLiteral(envPtr, bytes, len);
- bytes = TclGetStringFromObj(replacementObj, &len);
+ bytes = Tcl_GetStringFromObj(replacementObj, &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2);
TclEmitOpcode( INST_STR_MAP, envPtr);
done:
@@ -2477,11 +2495,11 @@
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
Tcl_Size numBytes;
- const char *bytes = TclGetStringFromObj(msg, &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)));
@@ -2735,11 +2753,11 @@
return -1;
}
Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size);
}
- tailName = TclGetStringFromObj(tailPtr, &len);
+ tailName = Tcl_GetStringFromObj(tailPtr, &len);
if (len) {
if (*(tailName + len - 1) == ')') {
/*
* Possible array: bail out
Index: generic/tclCompCmdsSZ.c
==================================================================
--- generic/tclCompCmdsSZ.c
+++ generic/tclCompCmdsSZ.c
@@ -1,22 +1,33 @@
/*
- * 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.
- *
* 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"
/*
@@ -250,11 +261,11 @@
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
Tcl_Size len;
- const char *bytes = TclGetStringFromObj(folded, &len);
+ const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
@@ -268,11 +279,11 @@
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
if (folded) {
Tcl_Size len;
- const char *bytes = TclGetStringFromObj(folded, &len);
+ const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
@@ -951,16 +962,16 @@
* 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 = TclGetStringFromObj(objv[0], &slen);
+ bytes = Tcl_GetStringFromObj(objv[0], &slen);
if (slen == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, slen);
- bytes = TclGetStringFromObj(objv[1], &slen);
+ bytes = Tcl_GetStringFromObj(objv[1], &slen);
PushLiteral(envPtr, bytes, slen);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
@@ -2916,11 +2927,11 @@
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
Tcl_Size len;
- const char *varname = TclGetStringFromObj(objv[0], &len);
+ const char *varname = Tcl_GetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
@@ -2928,11 +2939,11 @@
} else {
resultVarIndices[i] = -1;
}
if (objc == 2) {
Tcl_Size len;
- const char *varname = TclGetStringFromObj(objv[1], &len);
+ const char *varname = Tcl_GetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
@@ -3135,11 +3146,11 @@
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = TclGetStringFromObj(matchClauses[i], &slen);
+ p = Tcl_GetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
@@ -3347,11 +3358,11 @@
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- p = TclGetStringFromObj(matchClauses[i], &slen);
+ p = Tcl_GetStringFromObj(matchClauses[i], &slen);
PushLiteral(envPtr, p, slen);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
@@ -3675,11 +3686,11 @@
}
if (varCount == 0) {
const char *bytes;
Tcl_Size len;
- bytes = TclGetStringFromObj(leadingWord, &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++;
Index: generic/tclCompExpr.c
==================================================================
--- generic/tclCompExpr.c
+++ generic/tclCompExpr.c
@@ -1,16 +1,27 @@
+/*
+ * 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::+ .
- *
- * 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.
*/
#include "tclInt.h"
#include "tclCompile.h" /* CompileEnv */
@@ -2109,11 +2120,11 @@
* (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, &tclDoubleType)) {
+ if (TclHasInternalRep(literal, tclDoubleType)) {
const char *p = start;
while (p < end) {
if (!TclIsBareword(*p++)) {
/*
@@ -2350,11 +2361,11 @@
const char *p;
Tcl_Size length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
- p = TclGetStringFromObj(*funcObjv, &length);
+ p = Tcl_GetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterLiteral(envPtr,
Tcl_DStringValue(&cmdName),
Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr);
@@ -2506,11 +2517,11 @@
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
Tcl_Size length;
- const char *bytes = TclGetStringFromObj(literal, &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)) {
/*
@@ -2566,11 +2577,11 @@
if (TclHasStringRep(objPtr)) {
Tcl_Obj *tableValue;
Tcl_Size numBytes;
const char *bytes
- = TclGetStringFromObj(objPtr, &numBytes);
+ = Tcl_GetStringFromObj(objPtr, &numBytes);
idx = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, idx);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
Index: generic/tclCompile.c
==================================================================
--- generic/tclCompile.c
+++ generic/tclCompile.c
@@ -1,19 +1,30 @@
/*
- * 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").
- *
* 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
/*
@@ -722,11 +733,11 @@
"bytecode", /* name */
FreeByteCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetByteCodeFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
/*
* substCodeType provides the standard type management procedures for the
* substcode type, which represents substitution within a Tcl value.
@@ -736,11 +747,11 @@
"substcode", /* name */
FreeSubstCodeInternalRep, /* freeIntRepProc */
DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2
/*
* Helper macros.
@@ -798,11 +809,11 @@
}
traceInitialized = 1;
}
#endif
- stringPtr = TclGetStringFromObj(objPtr, &length);
+ 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.
@@ -1347,11 +1358,11 @@
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
Tcl_Size numBytes;
- const char *bytes = TclGetStringFromObj(objPtr, &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);
@@ -1837,11 +1848,11 @@
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- bytes = TclGetStringFromObj(cmdObj, &length);
+ bytes = Tcl_GetStringFromObj(cmdObj, &length);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
if (cmdPtr && TclRoutineHasName(cmdPtr)) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
@@ -2829,11 +2840,11 @@
* 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 = TclGetStringFromObj(objPtr, &numBytes);
+ const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
Tcl_IncrRefCount(copyPtr);
TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);
@@ -3070,11 +3081,11 @@
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = TclGetStringFromObj(*varNamePtr, &len);
+ localName = Tcl_GetStringFromObj(*varNamePtr, &len);
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
Index: generic/tclCompile.h
==================================================================
--- generic/tclCompile.h
+++ generic/tclCompile.h
@@ -1,17 +1,29 @@
/*
- * tclCompile.h --
- *
* 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
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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"
@@ -318,14 +330,12 @@
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.*/
-#if TCL_MAJOR_VERSION > 8
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
-#endif
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
@@ -337,13 +347,10 @@
* 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. */
-#if TCL_MAJOR_VERSION < 9
- int mallocedExceptArray;
-#endif
ExceptionAux *exceptAuxArrayPtr;
/* Array of information used to restore the
* state when processing BREAK/CONTINUE
* exceptions. Must be the same size as the
* exceptArrayPtr. */
@@ -352,23 +359,18 @@
* 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. */
-#if TCL_MAJOR_VERSION > 8
int mallocedAuxDataArray; /* 1 if aux data array was expanded and
* auxDataArrayPtr points in heap else 0. */
-#endif
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. */
-#if TCL_MAJOR_VERSION < 9
- int mallocedAuxDataArray;
-#endif
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];
@@ -1070,11 +1072,10 @@
*----------------------------------------------------------------
* Procedures exported by tclBasic.c to be used within the engine.
*----------------------------------------------------------------
*/
-#if TCL_MAJOR_VERSION > 8
MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine;
/*
*----------------------------------------------------------------
* Procedures exported by the engine to be used by tclBasic.c
@@ -1209,11 +1210,11 @@
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);
-#endif /* TCL_MAJOR_VERSION > 8 */
+
/*
*----------------------------------------------------------------
* Macros and flag values used by Tcl bytecode compilation and execution
* modules inside the Tcl core but not used outside.
Index: generic/tclConfig.c
==================================================================
--- generic/tclConfig.c
+++ generic/tclConfig.c
@@ -1,17 +1,28 @@
/*
- * tclConfig.c --
- *
- * This file provides the facilities which allow Tcl and other packages
- * to embed configuration information into their binary libraries.
- *
* Copyright © 2002 Andreas Kupries
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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.
*
Index: generic/tclDTrace.d
==================================================================
--- generic/tclDTrace.d
+++ generic/tclDTrace.d
@@ -1,19 +1,30 @@
/*
- * tclDTrace.d --
- *
- * Tcl DTrace provider.
- *
* Copyright (c) 2007-2008 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-typedef struct Tcl_Obj Tcl_Obj;
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
*/
Index: generic/tclDate.c
==================================================================
--- generic/tclDate.c
+++ generic/tclDate.c
@@ -76,13 +76,12 @@
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
- * Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
- * Copyright © 1995-1997 Sun Microsystems, Inc.
- * Copyright © 2015 Sergey G. Brester aka sebres.
+ * 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.
*
*/
@@ -95,24 +94,90 @@
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
-#if 0
-#define YYDEBUG 1
-#endif
+/*
+ * 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.
*/
-#include "tclDate.h"
+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
/*
@@ -120,28 +185,22 @@
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
-#define HOUR(x) ((60 * (int)(x)))
+#define HOUR(x) ((int) (60 * (x)))
+#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
-#define yyIncrFlags(f) \
- do { \
- info->errFlags |= (info->flags & (f)); \
- if (info->errFlags) { YYABORT; } \
- info->flags |= (f); \
- } while (0);
-
/*
* An entry in the lexical lookup table.
*/
-typedef struct {
+typedef struct _TABLE {
const char *name;
int type;
- int value;
+ time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
@@ -198,32 +257,28 @@
tMERIDIAN = 262, /* tMERIDIAN */
tMONTH = 263, /* tMONTH */
tMONTH_UNIT = 264, /* tMONTH_UNIT */
tSTARDATE = 265, /* tSTARDATE */
tSEC_UNIT = 266, /* tSEC_UNIT */
- tUNUMBER = 267, /* tUNUMBER */
- tZONE = 268, /* tZONE */
- tZONEwO4 = 269, /* tZONEwO4 */
- tZONEwO2 = 270, /* tZONEwO2 */
- tEPOCH = 271, /* tEPOCH */
- tDST = 272, /* tDST */
- tISOBAS8 = 273, /* tISOBAS8 */
- tISOBAS6 = 274, /* tISOBAS6 */
- tISOBASL = 275, /* tISOBASL */
- tDAY_UNIT = 276, /* tDAY_UNIT */
- tNEXT = 277, /* tNEXT */
- SP = 278 /* SP */
+ 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
{
- Tcl_WideInt Number;
+ time_t Number;
enum _MERIDIAN Meridian;
};
typedef union YYSTYPE YYSTYPE;
@@ -266,52 +321,40 @@
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_tUNUMBER = 12, /* tUNUMBER */
- YYSYMBOL_tZONE = 13, /* tZONE */
- YYSYMBOL_tZONEwO4 = 14, /* tZONEwO4 */
- YYSYMBOL_tZONEwO2 = 15, /* tZONEwO2 */
- YYSYMBOL_tEPOCH = 16, /* tEPOCH */
- YYSYMBOL_tDST = 17, /* tDST */
- YYSYMBOL_tISOBAS8 = 18, /* tISOBAS8 */
- YYSYMBOL_tISOBAS6 = 19, /* tISOBAS6 */
- YYSYMBOL_tISOBASL = 20, /* tISOBASL */
- YYSYMBOL_tDAY_UNIT = 21, /* tDAY_UNIT */
- YYSYMBOL_tNEXT = 22, /* tNEXT */
- YYSYMBOL_SP = 23, /* SP */
- YYSYMBOL_24_ = 24, /* ':' */
- YYSYMBOL_25_ = 25, /* ',' */
- YYSYMBOL_26_ = 26, /* '-' */
- YYSYMBOL_27_ = 27, /* '/' */
- YYSYMBOL_28_T_ = 28, /* 'T' */
- YYSYMBOL_29_ = 29, /* '.' */
- YYSYMBOL_30_ = 30, /* '+' */
- YYSYMBOL_YYACCEPT = 31, /* $accept */
- YYSYMBOL_spec = 32, /* spec */
- YYSYMBOL_item = 33, /* item */
- YYSYMBOL_iextime = 34, /* iextime */
- YYSYMBOL_time = 35, /* time */
- YYSYMBOL_zone = 36, /* zone */
- YYSYMBOL_comma = 37, /* comma */
- YYSYMBOL_day = 38, /* day */
- YYSYMBOL_iexdate = 39, /* iexdate */
- YYSYMBOL_date = 40, /* date */
- YYSYMBOL_ordMonth = 41, /* ordMonth */
- YYSYMBOL_isosep = 42, /* isosep */
- YYSYMBOL_isodate = 43, /* isodate */
- YYSYMBOL_isotime = 44, /* isotime */
- YYSYMBOL_iso = 45, /* iso */
- YYSYMBOL_trek = 46, /* trek */
- YYSYMBOL_relspec = 47, /* relspec */
- YYSYMBOL_relunits = 48, /* relunits */
- YYSYMBOL_sign = 49, /* sign */
- YYSYMBOL_unit = 50, /* unit */
- YYSYMBOL_INTNUM = 51, /* INTNUM */
- YYSYMBOL_numitem = 52, /* numitem */
- YYSYMBOL_o_merid = 53 /* o_merid */
+ 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. */
@@ -320,14 +363,16 @@
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
-static void TclDateerror(YYLTYPE* location,
+ static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
-static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
+ 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*);
@@ -653,23 +698,23 @@
#endif /* !YYCOPY_NEEDED */
/* YYFINAL -- State number of the termination state. */
#define YYFINAL 2
/* YYLAST -- Last index in YYTABLE. */
-#define YYLAST 98
+#define YYLAST 81
/* YYNTOKENS -- Number of terminals. */
-#define YYNTOKENS 31
+#define YYNTOKENS 26
/* YYNNTS -- Number of nonterminals. */
-#define YYNNTS 23
+#define YYNNTS 16
/* YYNRULES -- Number of rules. */
-#define YYNRULES 72
+#define YYNRULES 56
/* YYNSTATES -- Number of states. */
-#define YYNSTATES 103
+#define YYNSTATES 85
/* YYMAXUTOK -- Last valid token kind. */
-#define YYMAXUTOK 278
+#define YYMAXUTOK 274
/* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM
as returned by yylex, with out-of-bounds checking. */
#define YYTRANSLATE(YYX) \
@@ -683,15 +728,15 @@
{
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, 30, 25, 26, 29, 27, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 24, 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, 28, 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,
@@ -706,25 +751,23 @@
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, 20, 21, 22, 23
+ 15, 16, 17, 18, 19
};
#if YYDEBUG
/* YYRLINE[YYN] -- Source line where rule number YYN was defined. */
static const yytype_int16 yyrline[] =
{
- 0, 171, 171, 172, 176, 179, 182, 185, 188, 191,
- 194, 197, 201, 204, 209, 215, 221, 226, 230, 234,
- 238, 242, 246, 252, 253, 256, 260, 264, 268, 272,
- 276, 282, 288, 292, 297, 298, 303, 307, 312, 316,
- 321, 328, 332, 338, 338, 340, 345, 350, 352, 357,
- 359, 360, 368, 379, 393, 398, 401, 404, 407, 410,
- 413, 416, 421, 424, 429, 433, 437, 443, 446, 449,
- 454, 472, 475
+ 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])
@@ -738,158 +781,143 @@
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", "tUNUMBER", "tZONE", "tZONEwO4", "tZONEwO2", "tEPOCH",
- "tDST", "tISOBAS8", "tISOBAS6", "tISOBASL", "tDAY_UNIT", "tNEXT", "SP",
- "':'", "','", "'-'", "'/'", "'T'", "'.'", "'+'", "$accept", "spec",
- "item", "iextime", "time", "zone", "comma", "day", "iexdate", "date",
- "ordMonth", "isosep", "isodate", "isotime", "iso", "trek", "relspec",
- "relunits", "sign", "unit", "INTNUM", "numitem", "o_merid", YY_NULLPTR
+ "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 (-21)
+#define YYPACT_NINF (-18)
#define yypact_value_is_default(Yyn) \
((Yyn) == YYPACT_NINF)
-#define YYTABLE_NINF (-68)
+#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[] =
{
- -21, 11, -21, -20, -21, 5, -21, -9, -21, 46,
- 17, 9, 9, -21, -21, -21, 24, -21, 57, -21,
- -21, -21, 33, -21, -21, -21, -21, -21, -21, -15,
- -21, -21, -21, 45, 26, -21, -7, -21, 51, -21,
- -20, -21, -21, -21, 48, -21, -21, 67, 68, 52,
- 69, -21, -9, -9, -21, -21, -21, -21, 74, -21,
- -7, -21, -21, -21, -21, 44, -21, 79, 40, -7,
- -21, -21, 72, 73, -21, 62, 61, 63, 64, -21,
- -21, -21, -21, 66, -21, -21, -21, -21, 84, -7,
- -21, -21, -21, 80, 81, 82, 83, -21, -21, -21,
- -21, -21, -21
+ -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, 25, 19, 0, 66, 0, 64, 70,
- 18, 0, 0, 39, 45, 46, 0, 65, 0, 62,
- 63, 3, 71, 4, 5, 8, 47, 6, 7, 34,
- 10, 11, 9, 55, 0, 61, 0, 12, 23, 26,
- 36, 67, 69, 68, 0, 27, 15, 38, 0, 0,
- 0, 17, 0, 0, 52, 51, 30, 41, 67, 59,
- 0, 72, 16, 44, 43, 0, 54, 67, 0, 22,
- 58, 24, 0, 0, 40, 14, 0, 0, 32, 20,
- 21, 42, 60, 0, 48, 49, 50, 29, 67, 0,
- 57, 37, 53, 0, 0, 0, 0, 28, 56, 13,
- 35, 31, 33
+ 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[] =
{
- -21, -21, -21, 31, -21, -21, 58, -21, -21, -21,
- -21, -21, -21, -21, -21, -21, -21, -21, -5, -18,
- -6, -21, -21
+ -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, 21, 22, 23, 24, 39, 25, 26, 27,
- 28, 65, 29, 86, 30, 31, 32, 33, 34, 35,
- 36, 37, 62
+ 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[] =
{
- 59, 44, 6, 41, 8, 38, 52, 53, 63, 42,
- 43, 2, 60, 64, 17, 3, 4, 40, 70, 5,
- 6, 7, 8, 9, 10, 11, 12, 13, 69, 14,
- 15, 16, 17, 18, 51, 19, 54, 19, 67, 20,
- 61, 20, 82, 55, 42, 43, 79, 80, 66, 68,
- 45, 90, 88, 46, 47, -67, 83, -67, 42, 43,
- 76, 56, 89, 84, 77, 57, 6, -67, 8, 58,
- 48, 98, 49, 50, 71, 42, 43, 73, 17, 74,
- 75, 78, 81, 87, 91, 92, 93, 94, 97, 95,
- 48, 96, 99, 100, 101, 102, 85, 0, 72
+ 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[] =
{
- 18, 7, 9, 12, 11, 25, 11, 12, 23, 18,
- 19, 0, 18, 28, 21, 4, 5, 12, 36, 8,
- 9, 10, 11, 12, 13, 14, 15, 16, 34, 18,
- 19, 20, 21, 22, 17, 26, 12, 26, 12, 30,
- 7, 30, 60, 19, 18, 19, 52, 53, 3, 23,
- 4, 69, 12, 7, 8, 9, 12, 11, 18, 19,
- 8, 4, 68, 19, 12, 8, 9, 21, 11, 12,
- 24, 89, 26, 27, 23, 18, 19, 29, 21, 12,
- 12, 12, 8, 4, 12, 12, 24, 26, 4, 26,
- 24, 27, 12, 12, 12, 12, 65, -1, 40
+ 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, 32, 0, 4, 5, 8, 9, 10, 11, 12,
- 13, 14, 15, 16, 18, 19, 20, 21, 22, 26,
- 30, 33, 34, 35, 36, 38, 39, 40, 41, 43,
- 45, 46, 47, 48, 49, 50, 51, 52, 25, 37,
- 12, 12, 18, 19, 51, 4, 7, 8, 24, 26,
- 27, 17, 49, 49, 12, 19, 4, 8, 12, 50,
- 51, 7, 53, 23, 28, 42, 3, 12, 23, 51,
- 50, 23, 37, 29, 12, 12, 8, 12, 12, 51,
- 51, 8, 50, 12, 19, 34, 44, 4, 12, 51,
- 50, 12, 12, 24, 26, 26, 27, 4, 50, 12,
- 12, 12, 12
+ 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, 31, 32, 32, 33, 33, 33, 33, 33, 33,
- 33, 33, 33, 34, 34, 35, 35, 36, 36, 36,
- 36, 36, 36, 37, 37, 38, 38, 38, 38, 38,
- 38, 39, 40, 40, 40, 40, 40, 40, 40, 40,
- 40, 41, 41, 42, 42, 43, 43, 43, 44, 44,
- 45, 45, 45, 46, 47, 47, 48, 48, 48, 48,
- 48, 48, 49, 49, 50, 50, 50, 51, 51, 51,
- 52, 53, 53
+ 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, 5, 3, 2, 2, 2, 1, 1,
- 3, 3, 2, 1, 2, 1, 2, 2, 4, 3,
- 2, 5, 3, 5, 1, 5, 2, 4, 2, 1,
- 3, 2, 3, 1, 1, 1, 1, 1, 1, 1,
- 3, 2, 2, 4, 2, 1, 4, 3, 2, 2,
- 3, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 0, 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 };
@@ -1470,418 +1498,381 @@
YY_REDUCE_PRINT (yyn);
switch (yyn)
{
case 4: /* item: time */
{
- yyIncrFlags(CLF_TIME);
+ yyHaveTime++;
}
break;
case 5: /* item: zone */
{
- yyIncrFlags(CLF_ZONE);
+ yyHaveZone++;
}
break;
case 6: /* item: date */
{
- yyIncrFlags(CLF_HAVEDATE);
+ yyHaveDate++;
}
break;
case 7: /* item: ordMonth */
{
- yyIncrFlags(CLF_ORDINALMONTH);
+ yyHaveOrdinalMonth++;
}
break;
case 8: /* item: day */
{
- yyIncrFlags(CLF_DAYOFWEEK);
+ yyHaveDay++;
}
break;
case 9: /* item: relspec */
{
- info->flags |= CLF_RELCONV;
+ yyHaveRel++;
}
break;
case 10: /* item: iso */
{
- yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
+ yyHaveTime++;
+ yyHaveDate++;
}
break;
case 11: /* item: trek */
{
- yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
- info->flags |= CLF_RELCONV;
- }
- break;
-
- case 13: /* iextime: tUNUMBER ':' tUNUMBER ':' tUNUMBER */
- {
- yyHour = (yyvsp[-4].Number);
- yyMinutes = (yyvsp[-2].Number);
- yySeconds = (yyvsp[0].Number);
- }
- break;
-
- case 14: /* iextime: tUNUMBER ':' tUNUMBER */
- {
- yyHour = (yyvsp[-2].Number);
- yyMinutes = (yyvsp[0].Number);
- yySeconds = 0;
- }
- break;
-
- case 15: /* time: tUNUMBER tMERIDIAN */
+ yyHaveTime++;
+ yyHaveDate++;
+ yyHaveRel++;
+ }
+ break;
+
+ case 13: /* time: tUNUMBER tMERIDIAN */
{
yyHour = (yyvsp[-1].Number);
yyMinutes = 0;
yySeconds = 0;
yyMeridian = (yyvsp[0].Meridian);
}
break;
- case 16: /* time: iextime o_merid */
- {
+ 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 17: /* zone: tZONE tDST */
+ case 16: /* zone: tZONE tDST */
{
yyTimezone = (yyvsp[-1].Number);
+ if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSTon;
}
break;
- case 18: /* zone: tZONE */
+ case 17: /* zone: tZONE */
{
yyTimezone = (yyvsp[0].Number);
+ if (yyTimezone > HOUR( 12)) yyTimezone -= HOUR(100);
yyDSTmode = DSToff;
}
break;
- case 19: /* zone: tDAYZONE */
+ case 18: /* zone: tDAYZONE */
{
yyTimezone = (yyvsp[0].Number);
yyDSTmode = DSTon;
}
break;
- case 20: /* zone: tZONEwO4 sign INTNUM */
- { /* GMT+0100, GMT-1000, etc. */
- yyTimezone = (yyvsp[-2].Number) - (yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
- yyDSTmode = DSToff;
- }
- break;
-
- case 21: /* zone: tZONEwO2 sign INTNUM */
- { /* GMT+1, GMT-10, etc. */
- yyTimezone = (yyvsp[-2].Number) - (yyvsp[-1].Number)*((yyvsp[0].Number) * 60);
- yyDSTmode = DSToff;
- }
- break;
-
- case 22: /* zone: sign INTNUM */
- { /* +0100, -0100 */
+ case 19: /* zone: sign tUNUMBER */
+ {
yyTimezone = -(yyvsp[-1].Number)*((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60);
yyDSTmode = DSToff;
}
break;
- case 25: /* day: tDAY */
- {
- yyDayOrdinal = 1;
- yyDayOfWeek = (yyvsp[0].Number);
- }
- break;
-
- case 26: /* day: tDAY comma */
- {
- yyDayOrdinal = 1;
- yyDayOfWeek = (yyvsp[-1].Number);
- }
- break;
-
- case 27: /* day: tUNUMBER tDAY */
+ 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);
- yyDayOfWeek = (yyvsp[0].Number);
+ yyDayNumber = (yyvsp[0].Number);
}
break;
- case 28: /* day: sign SP tUNUMBER tDAY */
- {
- yyDayOrdinal = (yyvsp[-3].Number) * (yyvsp[-1].Number);
- yyDayOfWeek = (yyvsp[0].Number);
- }
- break;
-
- case 29: /* day: sign tUNUMBER tDAY */
+ case 23: /* day: sign tUNUMBER tDAY */
{
yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number);
- yyDayOfWeek = (yyvsp[0].Number);
+ yyDayNumber = (yyvsp[0].Number);
}
break;
- case 30: /* day: tNEXT tDAY */
+ case 24: /* day: tNEXT tDAY */
{
yyDayOrdinal = 2;
- yyDayOfWeek = (yyvsp[0].Number);
+ yyDayNumber = (yyvsp[0].Number);
}
break;
- case 31: /* iexdate: tUNUMBER '-' tUNUMBER '-' tUNUMBER */
- {
- yyMonth = (yyvsp[-2].Number);
- yyDay = (yyvsp[0].Number);
- yyYear = (yyvsp[-4].Number);
- }
- break;
-
- case 32: /* date: tUNUMBER '/' tUNUMBER */
+ case 25: /* date: tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-2].Number);
yyDay = (yyvsp[0].Number);
}
break;
- case 33: /* date: tUNUMBER '/' tUNUMBER '/' tUNUMBER */
+ case 26: /* date: tUNUMBER '/' tUNUMBER '/' tUNUMBER */
{
yyMonth = (yyvsp[-4].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
- case 35: /* date: tUNUMBER '-' tMONTH '-' tUNUMBER */
+ 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 36: /* date: tMONTH tUNUMBER */
+ 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 37: /* date: tMONTH tUNUMBER comma tUNUMBER */
- {
+ case 31: /* date: tMONTH tUNUMBER ',' tUNUMBER */
+ {
yyMonth = (yyvsp[-3].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
- case 38: /* date: tUNUMBER tMONTH */
+ case 32: /* date: tUNUMBER tMONTH */
{
yyMonth = (yyvsp[0].Number);
yyDay = (yyvsp[-1].Number);
}
break;
- case 39: /* date: tEPOCH */
+ case 33: /* date: tEPOCH */
{
yyMonth = 1;
yyDay = 1;
yyYear = EPOCH;
}
break;
- case 40: /* date: tUNUMBER tMONTH tUNUMBER */
+ case 34: /* date: tUNUMBER tMONTH tUNUMBER */
{
yyMonth = (yyvsp[-1].Number);
yyDay = (yyvsp[-2].Number);
yyYear = (yyvsp[0].Number);
}
break;
- case 41: /* ordMonth: tNEXT tMONTH */
- {
- yyMonthOrdinalIncr = 1;
- yyMonthOrdinal = (yyvsp[0].Number);
- }
- break;
-
- case 42: /* ordMonth: tNEXT tUNUMBER tMONTH */
- {
- yyMonthOrdinalIncr = (yyvsp[-1].Number);
- yyMonthOrdinal = (yyvsp[0].Number);
- }
- break;
-
- case 45: /* isodate: tISOBAS8 */
- { /* YYYYMMDD */
- yyYear = (yyvsp[0].Number) / 10000;
- yyMonth = ((yyvsp[0].Number) % 10000)/100;
- yyDay = (yyvsp[0].Number) % 100;
- }
- break;
-
- case 46: /* isodate: tISOBAS6 */
- { /* YYMMDD */
- yyYear = (yyvsp[0].Number) / 10000;
- yyMonth = ((yyvsp[0].Number) % 10000)/100;
- yyDay = (yyvsp[0].Number) % 100;
- }
- break;
-
- case 48: /* isotime: tISOBAS6 */
- {
+ 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 51: /* iso: tISOBASL tISOBAS6 */
- { /* YYYYMMDDhhmmss */
+ 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 52: /* iso: tISOBASL tUNUMBER */
- { /* YYYYMMDDhhmm */
- if (yyDigitCount != 4) YYABORT; /* normally unreached */
- yyYear = (yyvsp[-1].Number) / 10000;
- yyMonth = ((yyvsp[-1].Number) % 10000)/100;
- yyDay = (yyvsp[-1].Number) % 100;
- yyHour = (yyvsp[0].Number) / 100;
- yyMinutes = ((yyvsp[0].Number) % 100);
- yySeconds = 0;
- }
- break;
-
- case 53: /* trek: tSTARDATE INTNUM '.' tUNUMBER */
- {
+ 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) * (144LL * 60LL);
+ yyRelSeconds += (yyvsp[0].Number) * 144 * 60;
}
break;
- case 54: /* relspec: relunits tAGO */
+ case 42: /* relspec: relunits tAGO */
{
yyRelSeconds *= -1;
yyRelMonth *= -1;
yyRelDay *= -1;
}
break;
- case 56: /* relunits: sign SP INTNUM unit */
- {
- *yyRelPointer += (yyvsp[-3].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
- }
- break;
-
- case 57: /* relunits: sign INTNUM unit */
- {
- *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number);
- }
- break;
-
- case 58: /* relunits: INTNUM unit */
- {
- *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
- }
- break;
-
- case 59: /* relunits: tNEXT unit */
- {
- *yyRelPointer += (yyvsp[0].Number);
- }
- break;
-
- case 60: /* relunits: tNEXT INTNUM unit */
- {
- *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number);
- }
- break;
-
- case 61: /* relunits: unit */
- {
- *yyRelPointer += (yyvsp[0].Number);
- }
- break;
-
- case 62: /* sign: '-' */
- {
- (yyval.Number) = -1;
- }
- break;
-
- case 63: /* sign: '+' */
- {
- (yyval.Number) = 1;
- }
- break;
-
- case 64: /* unit: tSEC_UNIT */
+ 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 65: /* unit: tDAY_UNIT */
+ case 52: /* unit: tDAY_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelDay;
}
break;
- case 66: /* unit: tMONTH_UNIT */
+ case 53: /* unit: tMONTH_UNIT */
{
(yyval.Number) = (yyvsp[0].Number);
yyRelPointer = &yyRelMonth;
}
break;
- case 67: /* INTNUM: tUNUMBER */
- {
- (yyval.Number) = (yyvsp[0].Number);
- }
- break;
-
- case 68: /* INTNUM: tISOBAS6 */
- {
- (yyval.Number) = (yyvsp[0].Number);
- }
- break;
-
- case 69: /* INTNUM: tISOBAS8 */
- {
- (yyval.Number) = (yyvsp[0].Number);
- }
- break;
-
- case 70: /* numitem: tUNUMBER */
- {
- if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) {
+ case 54: /* number: tUNUMBER */
+ {
+ if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = (yyvsp[0].Number);
} else {
- yyIncrFlags(CLF_TIME);
+ yyHaveTime++;
if (yyDigitCount <= 2) {
yyHour = (yyvsp[0].Number);
yyMinutes = 0;
} else {
yyHour = (yyvsp[0].Number) / 100;
@@ -1891,17 +1882,17 @@
yyMeridian = MER24;
}
}
break;
- case 71: /* o_merid: %empty */
+ case 55: /* o_merid: %empty */
{
(yyval.Meridian) = MER24;
}
break;
- case 72: /* o_merid: tMERIDIAN */
+ case 56: /* o_merid: tMERIDIAN */
{
(yyval.Meridian) = (yyvsp[0].Meridian);
}
break;
@@ -2162,10 +2153,24 @@
{ "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 }
};
@@ -2261,48 +2266,38 @@
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
- { "a", tZONE, -HOUR( 1) },
- { "b", tZONE, -HOUR( 2) },
- { "c", tZONE, -HOUR( 3) },
- { "d", tZONE, -HOUR( 4) },
- { "e", tZONE, -HOUR( 5) },
- { "f", tZONE, -HOUR( 6) },
- { "g", tZONE, -HOUR( 7) },
- { "h", tZONE, -HOUR( 8) },
- { "i", tZONE, -HOUR( 9) },
- { "k", tZONE, -HOUR(10) },
- { "l", tZONE, -HOUR(11) },
- { "m", tZONE, -HOUR(12) },
- { "n", tZONE, HOUR( 1) },
- { "o", tZONE, HOUR( 2) },
- { "p", tZONE, HOUR( 3) },
- { "q", tZONE, HOUR( 4) },
- { "r", tZONE, HOUR( 5) },
- { "s", tZONE, HOUR( 6) },
- { "t", tZONE, HOUR( 7) },
- { "u", tZONE, HOUR( 8) },
- { "v", tZONE, HOUR( 9) },
- { "w", tZONE, HOUR( 10) },
- { "x", tZONE, HOUR( 11) },
- { "y", tZONE, HOUR( 12) },
- { "z", tZONE, HOUR( 0) },
+ { "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 }
};
-static inline const char *
-bypassSpaces(
- const char *s)
-{
- while (TclIsSpaceProc(*s)) {
- s++;
- }
- return s;
-}
-
/*
* Dump error messages in the bit bucket.
*/
static void
@@ -2310,13 +2305,10 @@
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
- if (!infoPtr->messages) {
- TclNewObj(infoPtr->messages);
- }
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);
@@ -2329,15 +2321,15 @@
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
-int
+static time_t
ToSeconds(
- int Hours,
- int Minutes,
- int Seconds,
+ time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
MERIDIAN Meridian)
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) {
return -1;
}
@@ -2344,21 +2336,21 @@
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23) {
return -1;
}
- return (Hours * 60 + Minutes) * 60 + Seconds;
+ return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12) {
return -1;
}
- return ((Hours % 12) * 60 + Minutes) * 60 + Seconds;
+ return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12) {
return -1;
}
- return (((Hours % 12) + 12) * 60 + Minutes) * 60 + Seconds;
+ return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
static int
@@ -2375,15 +2367,15 @@
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
- if (*buff == 'a' && (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0)) {
+ if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
- if (*buff == 'p' && (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0)) {
+ if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
@@ -2493,114 +2485,54 @@
{
char c;
char *p;
char buff[20];
int Count;
- const char *tokStart;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
-
- if (isspace(UCHAR(*yyInput))) {
- yyInput = bypassSpaces(yyInput);
- /* ignore space at end of text and before some words */
- c = *yyInput;
- if (c != '\0' && !isalpha(UCHAR(c))) {
- return SP;
- }
- }
- tokStart = yyInput;
+ while (TclIsSpaceProcM(*yyInput)) {
+ yyInput++;
+ }
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
-
- /*
- * Count the number of digits.
- */
- p = (char *)yyInput;
- while (isdigit(UCHAR(*++p))) {};
- yyDigitCount = p - yyInput;
- /*
- * A number with 12 or 14 digits is considered an ISO 8601 date.
- */
- if (yyDigitCount == 14 || yyDigitCount == 12) {
- /* long form of ISO 8601 (without separator), either
- * YYYYMMDDhhmmss or YYYYMMDDhhmm, so reduce to date
- * (8 chars is isodate) */
- p = (char *)yyInput+8;
- if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
- return tID; /* overflow*/
- }
- yyDigitCount = 8;
- yyInput = p;
- location->last_column = yyInput - info->dateStart - 1;
- return tISOBASL;
- }
- /*
- * Convert the string into a number
- */
- if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
- return tID; /* overflow*/
- }
- yyInput = p;
+ /*
+ * 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.
*/
- location->last_column = yyInput - info->dateStart - 1;
- if (yyDigitCount >= 6) {
- if (yyDigitCount == 8) {
- return tISOBAS8;
- }
- if (yyDigitCount == 6) {
- return tISOBAS6;
- }
- }
- /* ignore spaces after digits (optional) */
- yyInput = bypassSpaces(yyInput);
- return tUNUMBER;
+
+ 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. */
- int ret;
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
- if (p < &buff[sizeof(buff) - 1]) {
+ if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
- ret = LookupWord(yylvalPtr, buff);
- /*
- * lookahead:
- * for spaces to consider word boundaries (for instance
- * literal T in isodateTisotimeZ is not a TZ, but Z is UTC);
- * for +/- digit, to differentiate between "GMT+1000 day" and "GMT +1000 day";
- * bypass spaces after token (but ignore by TZ+OFFS), because should
- * recognize next SP token, if TZ only.
- */
- if (ret == tZONE || ret == tDAYZONE) {
- c = *yyInput;
- if (isdigit(UCHAR(c))) { /* literal not a TZ */
- yyInput = tokStart;
- return *yyInput++;
- }
- if ((c == '+' || c == '-') && isdigit(UCHAR(*(yyInput+1)))) {
- if ( !isdigit(UCHAR(*(yyInput+2)))
- || !isdigit(UCHAR(*(yyInput+3)))) {
- /* GMT+1, GMT-10, etc. */
- return tZONEwO2;
- }
- if ( isdigit(UCHAR(*(yyInput+4)))
- && !isdigit(UCHAR(*(yyInput+5)))) {
- /* GMT+1000, etc. */
- return tZONEwO4;
- }
- }
- }
- yyInput = bypassSpaces(yyInput);
- return ret;
-
+ return LookupWord(yylvalPtr, buff);
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
@@ -2616,83 +2548,177 @@
Count--;
}
} while (Count > 0);
}
}
-
+
int
-TclClockFreeScan(
+TclClockOldscanObjCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
- DateInfo *info) /* Input and result parameters */
+ 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 YYDEBUG
- /* enable debugging if compiled with YYDEBUG */
- yydebug = 1;
- #endif
-
- /*
- * yyInput = stringToParse;
- *
- * ClockInitDateInfo(info) should be executed to pre-init info;
- */
-
- yyDSTmode = DSTmaybe;
-
- info->separatrix = "";
-
- info->dateStart = yyInput;
-
- /* ignore spaces at begin */
- yyInput = bypassSpaces(yyInput);
-
- /* parse */
- status = yyparse(info);
+ 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) {
- const char *msg = NULL;
- if (info->errFlags & CLF_HAVEDATE) {
- msg = "more than one date in string";
- } else if (info->errFlags & CLF_TIME) {
- msg = "more than one time of day in string";
- } else if (info->errFlags & CLF_ZONE) {
- msg = "more than one time zone in string";
- } else if (info->errFlags & CLF_DAYOFWEEK) {
- msg = "more than one weekday in string";
- } else if (info->errFlags & CLF_ORDINALMONTH) {
- msg = "more than one ordinal month in string";
- }
- if (msg) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
- } else {
- Tcl_SetObjResult(interp,
- info->messages ? info->messages : Tcl_NewObj());
- info->messages = NULL;
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
- }
- status = TCL_ERROR;
+ 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);
- status = TCL_ERROR;
+ 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);
- status = TCL_ERROR;
+ 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));
}
- if (info->messages) {
- Tcl_DecrRefCount(info->messages);
+ Tcl_ListObjAppendElement(interp, result, resultElement);
+
+ TclNewObj(resultElement);
+ if (yyHaveOrdinalMonth) {
+ Tcl_ListObjAppendElement(interp, resultElement,
+ Tcl_NewIntObj(yyMonthOrdinal));
+ Tcl_ListObjAppendElement(interp, resultElement,
+ Tcl_NewIntObj(yyMonth));
}
- return status;
+ Tcl_ListObjAppendElement(interp, result, resultElement);
+
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
DELETED generic/tclDate.h
Index: generic/tclDate.h
==================================================================
--- generic/tclDate.h
+++ /dev/null
@@ -1,565 +0,0 @@
-/*
- * tclDate.h --
- *
- * This header file handles common usage of clock primitives
- * between tclDate.c (yacc), tclClock.c and tclClockFmt.c.
- *
- * Copyright (c) 2014 Serg G. Brester (aka sebres)
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef _TCLCLOCK_H
-#define _TCLCLOCK_H
-
-/*
- * Constants
- */
-
-#define JULIAN_DAY_POSIX_EPOCH 2440588
-#define GREGORIAN_CHANGE_DATE 2361222
-#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 */
-
-#define RODDENBERRY 1946 /* Another epoch (Hi, Jeff!) */
-
-enum DateInfoFlags {
- CLF_OPTIONAL = 1 << 0, /* token is non mandatory */
- CLF_POSIXSEC = 1 << 1,
- CLF_LOCALSEC = 1 << 2,
- CLF_JULIANDAY = 1 << 3,
- CLF_TIME = 1 << 4,
- CLF_ZONE = 1 << 5,
- CLF_CENTURY = 1 << 6,
- CLF_DAYOFMONTH = 1 << 7,
- CLF_DAYOFYEAR = 1 << 8,
- CLF_MONTH = 1 << 9,
- CLF_YEAR = 1 << 10,
- CLF_DAYOFWEEK = 1 << 11,
- CLF_ISO8601YEAR = 1 << 12,
- CLF_ISO8601WEEK = 1 << 13,
- CLF_ISO8601CENTURY = 1 << 14,
-
- CLF_SIGNED = 1 << 15,
-
- /* Compounds */
-
- CLF_HAVEDATE = (CLF_DAYOFMONTH | CLF_MONTH | CLF_YEAR),
- CLF_DATE = (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR
- | CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR
- | CLF_DAYOFWEEK | CLF_ISO8601WEEK),
-
- /*
- * Extra flags used outside of scan/format-tokens too (int, not a short).
- */
-
- CLF_RELCONV = 1 << 17,
- CLF_ORDINALMONTH = 1 << 18,
-
- /* On demand (lazy) assemble flags */
-
- CLF_ASSEMBLE_DATE = 1 << 28,/* assemble year, month, etc. using julianDay */
- CLF_ASSEMBLE_JULIANDAY = 1 << 29,
- /* assemble julianDay using year, month, etc. */
- CLF_ASSEMBLE_SECONDS = 1 << 30
- /* assemble localSeconds (and seconds at end) */
-};
-
-#define TCL_MIN_SECONDS -0x00F0000000000000LL
-#define TCL_MAX_SECONDS 0x00F0000000000000LL
-#define TCL_INV_SECONDS (TCL_MIN_SECONDS - 1)
-
-/*
- * Enumeration of the string literals used in [clock]
- */
-
-typedef enum ClockLiteral {
- LIT__NIL,
- LIT__DEFAULT_FORMAT,
- LIT_SYSTEM, LIT_CURRENT, LIT_C,
- LIT_BCE, 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_TZDATA,
- LIT_GETSYSTEMTIMEZONE,
- LIT_SETUPTIMEZONE,
- LIT_MCGET,
- LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE,
- LIT_LOCALIZE_FORMAT,
- LIT__END
-} ClockLiteral;
-
-#define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \
- "", \
- "%a %b %d %H:%M:%S %Z %Y", \
- "system", "current", "C", \
- "BCE", "CE", \
- "dayOfMonth", "dayOfWeek", "dayOfYear", \
- "era", ":GMT", "gregorian", \
- "integer value too large to represent", \
- "iso8601Week", "iso8601Year", \
- "julianDay", "localSeconds", \
- "month", \
- "seconds", "tzName", "tzOffset", \
- "year", \
- "::tcl::clock::TZData", \
- "::tcl::clock::GetSystemTimeZone", \
- "::tcl::clock::SetupTimeZone", \
- "::tcl::clock::mcget", \
- "::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \
- "::tcl::clock::LocalizeFormat" \
-}
-
-/*
- * Enumeration of the msgcat literals used in [clock]
- */
-
-typedef enum ClockMsgCtLiteral {
- MCLIT__NIL, /* placeholder */
- MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, MCLIT_MONTHS_COMB,
- MCLIT_DAYS_OF_WEEK_FULL, MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_COMB,
- MCLIT_AM, MCLIT_PM,
- MCLIT_LOCALE_ERAS,
- MCLIT_BCE, MCLIT_CE,
- MCLIT_BCE2, MCLIT_CE2,
- MCLIT_BCE3, MCLIT_CE3,
- MCLIT_LOCALE_NUMERALS,
- MCLIT__END
-} ClockMsgCtLiteral;
-
-#define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \
- pref "", \
- pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \
- pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \
- pref "AM", pref "PM", \
- pref "LOCALE_ERAS", \
- pref "BCE", pref "CE", \
- pref "b.c.e.", pref "c.e.", \
- pref "b.c.", pref "a.d.", \
- pref "LOCALE_NUMERALS", \
-}
-
-/*
- * Structure containing the fields used in [clock format] and [clock scan]
- */
-
-enum TclDateFieldsFlags {
- CLF_CTZ = (1 << 4)
-};
-
-typedef struct TclDateFields {
- /* Cacheable fields: */
-
- 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_WideInt 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 */
- int hour; /* Hours of day (in-between time only calculation) */
- int minutes; /* Minutes of hour (in-between time only calculation) */
- Tcl_WideInt secondOfMin; /* Seconds of minute (in-between time only calculation) */
- Tcl_WideInt secondOfDay; /* Seconds of day (in-between time only calculation) */
-
- int flags; /* 0 or CLF_CTZ */
-
- /* Non cacheable fields: */
-
- Tcl_Obj *tzName; /* Name (or corresponding DST-abbreviation) of the
- * time zone, if set the refCount is incremented */
-} TclDateFields;
-
-#define ClockCacheableDateFieldsSize \
- offsetof(TclDateFields, tzName)
-
-/*
- * Meridian: am, pm, or 24-hour style.
- */
-
-typedef enum _MERIDIAN {
- MERam, MERpm, MER24
-} MERIDIAN;
-
-/*
- * Structure contains return parsed fields.
- */
-
-typedef struct DateInfo {
- const char *dateStart;
- const char *dateInput;
- const char *dateEnd;
-
- TclDateFields date;
-
- int flags; /* Signals parts of date/time get found */
- int errFlags; /* Signals error (part of date/time found twice) */
-
- MERIDIAN dateMeridian;
-
- int dateTimezone;
- int dateDSTmode;
-
- Tcl_WideInt dateRelMonth;
- Tcl_WideInt dateRelDay;
- Tcl_WideInt dateRelSeconds;
-
- int dateMonthOrdinalIncr;
- int dateMonthOrdinal;
-
- int dateDayOrdinal;
-
- Tcl_WideInt *dateRelPointer;
-
- int dateSpaceCount;
- int dateDigitCount;
-
- int dateCentury;
-
- Tcl_Obj *messages; /* Error messages */
- const char* separatrix; /* String separating messages */
-} DateInfo;
-
-#define yydate (info->date) /* Date fields used for converting */
-
-#define yyDay (info->date.dayOfMonth)
-#define yyMonth (info->date.month)
-#define yyYear (info->date.year)
-
-#define yyHour (info->date.hour)
-#define yyMinutes (info->date.minutes)
-#define yySeconds (info->date.secondOfMin)
-#define yySecondOfDay (info->date.secondOfDay)
-
-#define yyDSTmode (info->dateDSTmode)
-#define yyDayOrdinal (info->dateDayOrdinal)
-#define yyDayOfWeek (info->date.dayOfWeek)
-#define yyMonthOrdinalIncr (info->dateMonthOrdinalIncr)
-#define yyMonthOrdinal (info->dateMonthOrdinal)
-#define yyTimezone (info->dateTimezone)
-#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 yySpaceCount (info->dateSpaceCount)
-
-static inline void
-ClockInitDateInfo(
- DateInfo *info)
-{
- memset(info, 0, sizeof(DateInfo));
-}
-
-/*
- * Structure containing the command arguments supplied to [clock format] and [clock scan]
- */
-
-enum ClockFmtScnCmdArgsFlags {
- CLF_VALIDATE_S1 = (1 << 0),
- CLF_VALIDATE_S2 = (1 << 1),
- CLF_VALIDATE = (CLF_VALIDATE_S1|CLF_VALIDATE_S2),
- CLF_EXTENDED = (1 << 4),
- CLF_STRICT = (1 << 8),
- CLF_LOCALE_USED = (1 << 15)
-};
-
-typedef struct ClockClientData ClockClientData;
-
-typedef struct ClockFmtScnCmdArgs {
- ClockClientData *dataPtr; /* Pointer to literal pool, etc. */
- Tcl_Interp *interp; /* Tcl interpreter */
- Tcl_Obj *formatObj; /* Format */
- Tcl_Obj *localeObj; /* Name of the locale where the time will be expressed. */
- Tcl_Obj *timezoneObj; /* Default time zone in which the time will be expressed */
- Tcl_Obj *baseObj; /* Base (scan and add) or clockValue (format) */
- int flags; /* Flags control scanning */
- Tcl_Obj *mcDictObj; /* Current dictionary of tcl::clock package for given localeObj*/
-} ClockFmtScnCmdArgs;
-
-/* Last-period cache for fast UTC to local and backwards conversion */
-typedef struct ClockLastTZOffs {
- /* keys */
- Tcl_Obj *timezoneObj;
- int changeover;
- Tcl_WideInt localSeconds;
- Tcl_WideInt rangesVal[2]; /* Bounds for cached time zone offset */
- /* values */
- int tzOffset;
- Tcl_Obj *tzName; /* Name (abbreviation) of this area in TZ */
-} ClockLastTZOffs;
-
-/*
- * Structure containing the client data for [clock]
- */
-
-typedef struct ClockClientData {
- size_t refCount; /* Number of live references. */
- Tcl_Obj **literals; /* Pool of object literals (common, locale independent). */
- Tcl_Obj **mcLiterals; /* Msgcat object literals with mc-keys for search with locale. */
- Tcl_Obj **mcLitIdxs; /* Msgcat object indices prefixed with _IDX_,
- * used for quick dictionary search */
- Tcl_Obj *mcDicts; /* Msgcat collection, contains weak pointers to locale
- * catalogs, and owns it references (onetime referenced) */
-
- /* Cache for current clock parameters, imparted via "configure" */
- size_t lastTZEpoch;
- int currentYearCentury;
- int yearOfCenturySwitch;
- int validMinYear;
- int validMaxYear;
- double maxJDN;
-
- Tcl_Obj *systemTimeZone;
- Tcl_Obj *systemSetupTZData;
- Tcl_Obj *gmtSetupTimeZoneUnnorm;
- Tcl_Obj *gmtSetupTimeZone;
- Tcl_Obj *gmtSetupTZData;
- Tcl_Obj *gmtTZName;
- Tcl_Obj *lastSetupTimeZoneUnnorm;
- Tcl_Obj *lastSetupTimeZone;
- Tcl_Obj *lastSetupTZData;
- Tcl_Obj *prevSetupTimeZoneUnnorm;
- Tcl_Obj *prevSetupTimeZone;
- Tcl_Obj *prevSetupTZData;
-
- Tcl_Obj *defaultLocale;
- Tcl_Obj *defaultLocaleDict;
- Tcl_Obj *currentLocale;
- Tcl_Obj *currentLocaleDict;
- Tcl_Obj *lastUsedLocaleUnnorm;
- Tcl_Obj *lastUsedLocale;
- Tcl_Obj *lastUsedLocaleDict;
- Tcl_Obj *prevUsedLocaleUnnorm;
- Tcl_Obj *prevUsedLocale;
- Tcl_Obj *prevUsedLocaleDict;
-
- /* Cache for last base (last-second fast convert if base/tz not changed) */
- struct {
- Tcl_Obj *timezoneObj;
- TclDateFields date;
- } lastBase;
-
- /* Last-period cache for fast UTC to Local and backwards conversion */
- ClockLastTZOffs lastTZOffsCache[2];
-
- int defFlags; /* Default flags (from configure), ATM
- * only CLF_VALIDATE supported */
-} ClockClientData;
-
-#define ClockDefaultYearCentury 2000
-#define ClockDefaultCenturySwitch 38
-
-/*
- * Clock scan and format facilities.
- */
-
-#ifndef TCL_MEM_DEBUG
-# define CLOCK_FMT_SCN_STORAGE_GC_SIZE 32
-#else
-# define CLOCK_FMT_SCN_STORAGE_GC_SIZE 0
-#endif
-
-#define CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE 2
-
-typedef struct ClockScanToken ClockScanToken;
-
-typedef int ClockScanTokenProc(
- ClockFmtScnCmdArgs *opts,
- DateInfo *info,
- ClockScanToken *tok);
-
-typedef enum _CLCKTOK_TYPE {
- CTOKT_INT = 1, CTOKT_WIDE, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR,
- CFMTT_PROC
-} CLCKTOK_TYPE;
-
-typedef struct ClockScanTokenMap {
- unsigned short type;
- unsigned short flags;
- unsigned short clearFlags;
- unsigned short minSize;
- unsigned short maxSize;
- unsigned short offs;
- ClockScanTokenProc *parser;
- const void *data;
-} ClockScanTokenMap;
-
-struct ClockScanToken {
- const ClockScanTokenMap *map;
- struct {
- const char *start;
- const char *end;
- } tokWord;
- unsigned short endDistance;
- unsigned short lookAhMin;
- unsigned short lookAhMax;
- unsigned short lookAhTok;
-};
-
-#define MIN_FMT_RESULT_BLOCK_ALLOC 80
-#define MIN_FMT_RESULT_BLOCK_DELTA 0
-/* Maximal permitted threshold (buffer size > result size) in percent,
- * to directly return the buffer without reallocate */
-#define MAX_FMT_RESULT_THRESHOLD 2
-
-typedef struct DateFormat {
- char *resMem;
- char *resEnd;
- char *output;
- TclDateFields date;
- Tcl_Obj *localeEra;
-} DateFormat;
-
-enum ClockFormatTokenMapFlags {
- CLFMT_INCR = (1 << 3),
- CLFMT_DECR = (1 << 4),
- CLFMT_CALC = (1 << 5),
- CLFMT_LOCALE_INDX = (1 << 8)
-};
-
-typedef struct ClockFormatToken ClockFormatToken;
-
-typedef int ClockFormatTokenProc(
- ClockFmtScnCmdArgs *opts,
- DateFormat *dateFmt,
- ClockFormatToken *tok,
- int *val);
-
-typedef struct ClockFormatTokenMap {
- unsigned short type;
- const char *tostr;
- unsigned short width;
- unsigned short flags;
- unsigned short divider;
- unsigned short divmod;
- unsigned short offs;
- ClockFormatTokenProc *fmtproc;
- void *data;
-} ClockFormatTokenMap;
-
-struct ClockFormatToken {
- const ClockFormatTokenMap *map;
- struct {
- const char *start;
- const char *end;
- } tokWord;
-};
-
-typedef struct ClockFmtScnStorage ClockFmtScnStorage;
-
-struct ClockFmtScnStorage {
- int objRefCount; /* Reference count shared across threads */
- ClockScanToken *scnTok;
- unsigned scnTokC;
- unsigned scnSpaceCount; /* Count of mandatory spaces used in format */
- ClockFormatToken *fmtTok;
- unsigned fmtTokC;
-#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
- ClockFmtScnStorage *nextPtr;
- ClockFmtScnStorage *prevPtr;
-#endif
- size_t fmtMinAlloc;
-#if 0
- Tcl_HashEntry hashEntry /* ClockFmtScnStorage is a derivate of Tcl_HashEntry,
- * stored by offset +sizeof(self) */
-#endif
-};
-
-/*
- * Clock macros.
- */
-
-/*
- * Extracts Julian day and seconds of the day from posix seconds (tm).
- */
-#define ClockExtractJDAndSODFromSeconds(jd, sod, tm) \
- do { \
- jd = (tm + JULIAN_SEC_POSIX_EPOCH); \
- if (jd >= SECONDS_PER_DAY || jd <= -SECONDS_PER_DAY) { \
- jd /= SECONDS_PER_DAY; \
- sod = (int)(tm % SECONDS_PER_DAY); \
- } else { \
- sod = (int)jd, jd = 0; \
- } \
- if (sod < 0) { \
- sod += SECONDS_PER_DAY; \
- /* JD is affected, if switched into negative (avoid 24 hours difference) */ \
- if (jd <= 0) { \
- jd--; \
- } \
- } \
- } while(0)
-
-/*
- * Prototypes of module functions.
- */
-
-MODULE_SCOPE int ToSeconds(int Hours, int Minutes,
- int Seconds, MERIDIAN Meridian);
-MODULE_SCOPE int IsGregorianLeapYear(TclDateFields *);
-MODULE_SCOPE void GetJulianDayFromEraYearWeekDay(
- TclDateFields *fields, int changeover);
-MODULE_SCOPE void GetJulianDayFromEraYearMonthDay(
- TclDateFields *fields, int changeover);
-MODULE_SCOPE void GetJulianDayFromEraYearDay(
- TclDateFields *fields, int changeover);
-MODULE_SCOPE int ConvertUTCToLocal(ClockClientData *dataPtr, Tcl_Interp *,
- TclDateFields *, Tcl_Obj *timezoneObj, int);
-MODULE_SCOPE Tcl_Obj * LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
- Tcl_Size, Tcl_Obj *const *, Tcl_WideInt *rangesVal);
-MODULE_SCOPE int TclClockFreeScan(Tcl_Interp *interp, DateInfo *info);
-
-/* tclClock.c module declarations */
-
-MODULE_SCOPE Tcl_Obj * ClockSetupTimeZone(ClockClientData *dataPtr,
- Tcl_Interp *interp, Tcl_Obj *timezoneObj);
-MODULE_SCOPE Tcl_Obj * ClockMCDict(ClockFmtScnCmdArgs *opts);
-MODULE_SCOPE Tcl_Obj * ClockMCGet(ClockFmtScnCmdArgs *opts, int mcKey);
-MODULE_SCOPE Tcl_Obj * ClockMCGetIdx(ClockFmtScnCmdArgs *opts, int mcKey);
-MODULE_SCOPE int ClockMCSetIdx(ClockFmtScnCmdArgs *opts, int mcKey,
- Tcl_Obj *valObj);
-
-/* tclClockFmt.c module declarations */
-
-MODULE_SCOPE char * TclItoAw(char *buf, int val, char padchar, unsigned short width);
-MODULE_SCOPE int TclAtoWIe(Tcl_WideInt *out, const char *p, const char *e, int sign);
-
-MODULE_SCOPE Tcl_Obj* ClockFrmObjGetLocFmtKey(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-MODULE_SCOPE ClockFmtScnStorage *Tcl_GetClockFrmScnFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-MODULE_SCOPE Tcl_Obj * ClockLocalizeFormat(ClockFmtScnCmdArgs *opts);
-MODULE_SCOPE int ClockScan(DateInfo *info, Tcl_Obj *strObj,
- ClockFmtScnCmdArgs *opts);
-MODULE_SCOPE int ClockFormat(DateFormat *dateFmt,
- ClockFmtScnCmdArgs *opts);
-MODULE_SCOPE void ClockFrmScnClearCaches(void);
-MODULE_SCOPE void ClockFrmScnFinalize();
-
-#endif /* _TCLCLOCK_H */
Index: generic/tclDecls.h
==================================================================
--- generic/tclDecls.h
+++ generic/tclDecls.h
@@ -6,10 +6,19 @@
* 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 /* for size_t */
@@ -25,14 +34,12 @@
# endif
#endif
#if !defined(BUILD_tcl)
# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg)
-#elif defined(TCL_NO_DEPRECATED)
-# define TCL_DEPRECATED(msg) MODULE_SCOPE
#else
-# define TCL_DEPRECATED(msg) EXTERN
+# define TCL_DEPRECATED(msg) MODULE_SCOPE
#endif
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -153,31 +160,25 @@
/* 39 */
EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, long *longPtr);
/* 40 */
EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName);
-/* 41 */
-EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr);
+/* 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);
-/* 45 */
-EXTERN int TclListObjGetElements(Tcl_Interp *interp,
- Tcl_Obj *listPtr, void *objcPtr,
- Tcl_Obj ***objvPtr);
+/* Slot 45 is reserved */
/* 46 */
EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Size index,
Tcl_Obj **objPtrPtr);
-/* 47 */
-EXTERN int TclListObjLength(Tcl_Interp *interp,
- Tcl_Obj *listPtr, void *lengthPtr);
+/* 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[]);
@@ -1871,10 +1872,120 @@
/* 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;
@@ -1923,17 +2034,17 @@
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 */
- char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 41 */
+ 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 */
- int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr); /* 45 */
+ void (*reserved45)(void);
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */
- int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *lengthPtr); /* 47 */
+ 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);
@@ -2573,10 +2684,41 @@
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
@@ -2666,24 +2808,21 @@
(tclStubsPtr->tcl_GetIntFromObj) /* 38 */
#define Tcl_GetLongFromObj \
(tclStubsPtr->tcl_GetLongFromObj) /* 39 */
#define Tcl_GetObjType \
(tclStubsPtr->tcl_GetObjType) /* 40 */
-#define TclGetStringFromObj \
- (tclStubsPtr->tclGetStringFromObj) /* 41 */
+/* 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 */
-#define TclListObjGetElements \
- (tclStubsPtr->tclListObjGetElements) /* 45 */
+/* Slot 45 is reserved */
#define Tcl_ListObjIndex \
(tclStubsPtr->tcl_ListObjIndex) /* 46 */
-#define TclListObjLength \
- (tclStubsPtr->tclListObjLength) /* 47 */
+/* Slot 47 is reserved */
#define Tcl_ListObjReplace \
(tclStubsPtr->tcl_ListObjReplace) /* 48 */
/* Slot 49 is reserved */
#define Tcl_NewByteArrayObj \
(tclStubsPtr->tcl_NewByteArrayObj) /* 50 */
@@ -3906,10 +4045,72 @@
(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. */
@@ -4030,44 +4231,38 @@
#define Tcl_GetUnicode(objPtr) \
Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL)
#undef Tcl_GetIndexFromObjStruct
#undef Tcl_GetBooleanFromObj
#undef Tcl_GetBoolean
-#if !defined(TCLBOOLWARNING)
-#if !defined(__cplusplus) && !defined(BUILD_tcl) && !defined(BUILD_tk) && defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L)
+#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__) && !defined(__STRICT_ANSI__)
+#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];}),
+# define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}),
#else
# define TCLBOOLWARNING(boolPtr)
#endif
-#endif /* !TCLBOOLWARNING */
-#if defined(USE_TCL_STUBS)
-#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
- (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \
- (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
-#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
- ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
- ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
- (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
-#define Tcl_GetBoolean(interp, src, boolPtr) \
- ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
- ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
- (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
-#else
-#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
- ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
- (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
-#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
- ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
- ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
- (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
-#define Tcl_GetBoolean(interp, src, boolPtr) \
- ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
- ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \
- (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)))
+#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
+#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) \
@@ -4092,42 +4287,10 @@
#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 TCL_UTF_MAX < 4
-# undef Tcl_UniCharToUtfDString
-# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
-# undef Tcl_UtfToUniCharDString
-# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
-# undef Tcl_UtfToUniChar
-# define Tcl_UtfToUniChar Tcl_UtfToChar16
-# undef Tcl_UniCharLen
-# define Tcl_UniCharLen Tcl_Char16Len
-# undef Tcl_UniCharToUtf
-# if defined(USE_TCL_STUBS)
-# define Tcl_UniCharToUtf(c, p) \
- (tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p)))
-# else
-# define Tcl_UniCharToUtf(c, p) \
- ((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p)))
-# endif
-# undef Tcl_NumUtfChars
-# define Tcl_NumUtfChars TclNumUtfChars
-# undef Tcl_GetCharLength
-# define Tcl_GetCharLength TclGetCharLength
-# undef Tcl_UtfAtIndex
-# define Tcl_UtfAtIndex TclUtfAtIndex
-# undef Tcl_GetRange
-# define Tcl_GetRange TclGetRange
-# undef Tcl_GetUniChar
-# define Tcl_GetUniChar TclGetUniChar
-# undef Tcl_UtfNcmp
-# define Tcl_UtfNcmp TclUtfNcmp
-# undef Tcl_UtfNcasecmp
-# define Tcl_UtfNcasecmp TclUtfNcasecmp
-#endif
#if defined(USE_TCL_STUBS)
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
: (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString)
# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
@@ -4161,174 +4324,13 @@
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
-#if TCL_MAJOR_VERSION > 8
-# undef Tcl_Close
-# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
-#endif
+# undef Tcl_Close
+# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#undef TclUtfCharComplete
#undef TclUtfNext
#undef TclUtfPrev
-#ifndef TCL_NO_DEPRECATED
-# define Tcl_CreateSlave Tcl_CreateChild
-# define Tcl_GetSlave Tcl_GetChild
-# define Tcl_GetMaster Tcl_GetParent
-#endif
-
-/* Protect those 11 functions, make them useless through the stub table */
-#undef TclGetStringFromObj
-#undef TclGetBytesFromObj
-#undef TclGetUnicodeFromObj
-#undef TclListObjGetElements
-#undef TclListObjLength
-#undef TclDictObjSize
-#undef TclSplitList
-#undef TclSplitPath
-#undef TclFSSplitPath
-#undef TclParseArgsObjv
-#undef TclGetAliasObj
-
-#if TCL_MAJOR_VERSION < 9
- /* TIP #627 for 8.7 */
-# undef Tcl_CreateObjCommand2
-# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand
-# undef Tcl_CreateObjTrace2
-# define Tcl_CreateObjTrace2 Tcl_CreateObjTrace
-# undef Tcl_NRCreateCommand2
-# define Tcl_NRCreateCommand2 Tcl_NRCreateCommand
-# undef Tcl_NRCallObjProc2
-# define Tcl_NRCallObjProc2 Tcl_NRCallObjProc
- /* TIP #660 for 8.7 */
-# undef Tcl_GetSizeIntFromObj
-# define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj
-
-# undef Tcl_GetBytesFromObj
-# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
- tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr))
-# undef Tcl_GetStringFromObj
-# define Tcl_GetStringFromObj(objPtr, sizePtr) \
- tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr))
-# undef Tcl_GetUnicodeFromObj
-# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
- tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr))
-# undef Tcl_ListObjGetElements
-# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
- tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr))
-# undef Tcl_ListObjLength
-# define Tcl_ListObjLength(interp, listPtr, lengthPtr) \
- tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr))
-# undef Tcl_DictObjSize
-# define Tcl_DictObjSize(interp, dictPtr, sizePtr) \
- tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr))
-# undef Tcl_SplitList
-# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) \
- tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr))
-# undef Tcl_SplitPath
-# define Tcl_SplitPath(path, argcPtr, argvPtr) \
- tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr))
-# undef Tcl_FSSplitPath
-# define Tcl_FSSplitPath(pathPtr, lenPtr) \
- tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr))
-# undef Tcl_ParseArgsObjv
-# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \
- tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv))
-# undef Tcl_GetAliasObj
-# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \
- tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv))
-#elif defined(TCL_8_API)
-# undef Tcl_GetByteArrayFromObj
-# undef Tcl_GetBytesFromObj
-# undef Tcl_GetStringFromObj
-# undef Tcl_GetUnicodeFromObj
-# undef Tcl_ListObjGetElements
-# undef Tcl_ListObjLength
-# undef Tcl_DictObjSize
-# undef Tcl_SplitList
-# undef Tcl_SplitPath
-# undef Tcl_FSSplitPath
-# undef Tcl_ParseArgsObjv
-# undef Tcl_GetAliasObj
-# if !defined(USE_TCL_STUBS)
-# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \
- (Tcl_GetBytesFromObj)(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- TclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \
- (Tcl_GetBytesFromObj)((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- (TclGetStringFromObj)((objPtr), (sizePtr)) : \
- (Tcl_GetStringFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- TclGetUnicodeFromObj((objPtr), (sizePtr)) : \
- (Tcl_GetUnicodeFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- (TclListObjGetElements)((interp), (listPtr), (objcPtr), (objvPtr)) : \
- (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
-# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \
- (TclListObjLength)((interp), (listPtr), (lengthPtr)) : \
- (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
-# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- TclDictObjSize((interp), (dictPtr), (sizePtr)) : \
- (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \
- TclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \
- (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
-# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \
- TclSplitPath((path), (argcPtr), (argvPtr)) : \
- (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
-# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \
- TclFSSplitPath((pathPtr), (lenPtr)) : \
- (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
-# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \
- (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
-# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \
- (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv)))
-# elif !defined(BUILD_tcl)
-# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \
- tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \
- tclStubsPtr->tcl_GetBytesFromObj((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) : \
- tclStubsPtr->tcl_GetStringFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) : \
- tclStubsPtr->tcl_GetUnicodeFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \
- tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr)))
-# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) : \
- tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr)))
-# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \
- tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) : \
- tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr)))
-# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \
- tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
-# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) : \
- tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr)))
-# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) : \
- tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr)))
-# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \
- tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv)))
-# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \
- tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \
- tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv)))
-# endif /* defined(USE_TCL_STUBS) */
-#else /* !defined(TCL_8_API) */
-# undef Tcl_GetByteArrayFromObj
-# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
- Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr))
-#endif /* defined(TCL_8_API) */
#endif /* _TCLDECLS */
Index: generic/tclDictObj.c
==================================================================
--- generic/tclDictObj.c
+++ generic/tclDictObj.c
@@ -1,17 +1,30 @@
/*
- * tclDictObj.c --
- *
- * This file contains functions that implement the Tcl dict object type
- * and its accessor command.
- *
* 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
/*
@@ -60,10 +73,13 @@
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[] = {
@@ -127,12 +143,14 @@
* 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 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;
@@ -139,32 +157,40 @@
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
-const Tcl_ObjType tclDictType = {
+
+ObjInterface dictObjInterface;
+
+
+
+static ObjectType tclDictObjectType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 2,
+ NULL
};
-#define DictSetInternalRep(objPtr, dictRepPtr) \
+Tcl_ObjType *tclDictTypePtr = (Tcl_ObjType *)&tclDictObjectType;
+
+#define DictSetIntRep(objPtr, dictRepPtr) \
do { \
- Tcl_ObjInternalRep ir; \
+ Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
- Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \
+ Tcl_StoreInternalRep((objPtr), tclDictTypePtr, &ir); \
} while (0)
#define DictGetInternalRep(objPtr, dictRepPtr) \
do { \
- const Tcl_ObjInternalRep *irPtr; \
- irPtr = TclFetchInternalRep((objPtr), &tclDictType); \
- (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
+ 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
@@ -198,10 +224,19 @@
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 *****/
/*
*----------------------------------------------------------------------
@@ -394,11 +429,11 @@
/*
* Store in the object.
*/
- DictSetInternalRep(copyPtr, newDict);
+ DictSetIntRep(copyPtr, newDict);
}
/*
*----------------------------------------------------------------------
*
@@ -528,15 +563,15 @@
* elements already.
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
- elem = TclGetStringFromObj(keyPtr, &length);
+ 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 = TclGetStringFromObj(valuePtr, &length);
+ elem = Tcl_GetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
}
bytesNeeded += numElems;
/*
@@ -546,17 +581,17 @@
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; inextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
- elem = TclGetStringFromObj(keyPtr, &length);
+ 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 = TclGetStringFromObj(valuePtr, &length);
+ 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);
@@ -593,19 +628,20 @@
{
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, &tclListType)) {
+ 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);
@@ -623,21 +659,21 @@
/*
* 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 = TclGetStringFromObj(objPtr, &length);
+ const char *nextElem = Tcl_GetStringFromObj(objPtr, &length);
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
@@ -692,10 +728,11 @@
/* 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 */
@@ -709,11 +746,11 @@
*/
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DictSetInternalRep(objPtr, dict);
+ DictSetIntRep(objPtr, dict);
return TCL_OK;
missingValue:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -888,11 +925,11 @@
do {
dict->refCount++;
TclInvalidateStringRep(dictObj);
TclFreeInternalRep(dictObj);
- DictSetInternalRep(dictObj, dict);
+ DictSetIntRep(dictObj, dict);
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
@@ -943,11 +980,11 @@
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeInternalRep(dictPtr)
- DictSetInternalRep(dictPtr, dict);
+ DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
@@ -1424,11 +1461,11 @@
dict = (Dict *)Tcl_Alloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DictSetInternalRep(dictPtr, dict);
+ DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
}
/*
@@ -1472,11 +1509,11 @@
dict = (Dict *)Tcl_Alloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
- DictSetInternalRep(dictPtr, dict);
+ DictSetIntRep(dictPtr, dict);
return dictPtr;
}
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDictObj(
@@ -1507,11 +1544,11 @@
*----------------------------------------------------------------------
*/
static int
DictCreateCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictObj;
@@ -1557,11 +1594,11 @@
*----------------------------------------------------------------------
*/
static int
DictGetCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr = NULL;
@@ -1650,11 +1687,11 @@
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
@@ -1715,11 +1752,11 @@
*----------------------------------------------------------------------
*/
static int
DictReplaceCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
@@ -1763,11 +1800,11 @@
*----------------------------------------------------------------------
*/
static int
DictRemoveCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
@@ -1811,11 +1848,11 @@
*----------------------------------------------------------------------
*/
static int
DictMergeCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
@@ -1898,11 +1935,11 @@
*----------------------------------------------------------------------
*/
static int
DictKeysCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *listPtr;
@@ -1977,11 +2014,11 @@
*----------------------------------------------------------------------
*/
static int
DictValuesCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *valuePtr = NULL, *listPtr;
@@ -2037,80 +2074,26 @@
*----------------------------------------------------------------------
*/
static int
DictSizeCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result;
- Tcl_Size size;
+ 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, &tclDictType)
- && 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 = &tclDictType;
-
return result;
}
/*
*----------------------------------------------------------------------
@@ -2130,11 +2113,11 @@
*----------------------------------------------------------------------
*/
static int
DictExistsCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr;
@@ -2172,11 +2155,11 @@
*----------------------------------------------------------------------
*/
static int
DictInfoCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Dict *dict;
@@ -2216,11 +2199,11 @@
*----------------------------------------------------------------------
*/
static int
DictIncrCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int code = TCL_OK;
@@ -2337,11 +2320,11 @@
*----------------------------------------------------------------------
*/
static int
DictLappendCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
@@ -2424,11 +2407,11 @@
*----------------------------------------------------------------------
*/
static int
DictAppendCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
@@ -2526,11 +2509,11 @@
*----------------------------------------------------------------------
*/
static int
DictForNRCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -2722,11 +2705,11 @@
*----------------------------------------------------------------------
*/
static int
DictMapNRCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -2935,11 +2918,11 @@
*----------------------------------------------------------------------
*/
static int
DictSetCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
@@ -2995,11 +2978,11 @@
*----------------------------------------------------------------------
*/
static int
DictUnsetCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
@@ -3054,11 +3037,11 @@
*----------------------------------------------------------------------
*/
static int
DictFilterCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -3340,11 +3323,11 @@
*----------------------------------------------------------------------
*/
static int
DictUpdateCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -3499,11 +3482,11 @@
*----------------------------------------------------------------------
*/
static int
DictWithCmd(
- TCL_UNUSED(void *),
+ TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
@@ -3839,13 +3822,60 @@
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:
*/
Index: generic/tclDisassemble.c
==================================================================
--- generic/tclDisassemble.c
+++ generic/tclDisassemble.c
@@ -1,19 +1,31 @@
/*
- * tclDisassemble.c --
- *
- * This file contains procedures that disassemble bytecode into either
- * human-readable or Tcl-processable forms.
- *
* 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
@@ -40,11 +52,11 @@
"instname", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define InstNameSetInternalRep(objPtr, inst) \
do { \
Tcl_ObjInternalRep ir; \
@@ -196,11 +208,11 @@
Tcl_Size maxChars) /* Maximum number of chars to print. */
{
char *bytes;
Tcl_Size length;
- bytes = TclGetStringFromObj(objPtr, &length);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
/*
*----------------------------------------------------------------------
@@ -653,11 +665,11 @@
if (suffixObj) {
const char *bytes;
Tcl_Size length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
- bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
+ 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);
@@ -951,11 +963,11 @@
/*
* Get the literals from the bytecode.
*/
TclNewObj(literals);
- for (i=0 ; inumLitObjects ; i++) {
+ for (i=0 ; i<(int)codePtr->numLitObjects ; i++) {
Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]);
}
/*
* Get the variables from the bytecode.
Index: generic/tclEncoding.c
==================================================================
--- generic/tclEncoding.c
+++ generic/tclEncoding.c
@@ -1,16 +1,27 @@
/*
- * tclEncoding.c --
- *
- * Contains the implementation of the encoding conversion package.
- *
* 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
typedef size_t (LengthProc)(const char *src);
@@ -268,11 +279,11 @@
"encoding",
FreeEncodingInternalRep,
DupEncodingInternalRep,
NULL,
NULL,
- TCL_OBJTYPE_V0
+ 0
};
#define EncodingSetInternalRep(objPtr, encoding) \
do { \
Tcl_ObjInternalRep ir; \
@@ -604,15 +615,10 @@
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16";
type.clientData = INT2PTR(leFlags);
Tcl_CreateEncoding(&type);
-#ifndef TCL_NO_DEPRECATED
- type.encodingName = "unicode";
- Tcl_CreateEncoding(&type);
-#endif
-
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
* table encoding or some of the escape encodings crash! Hence the ugly
* code to duplicate the structure of a table encoding here.
@@ -1105,11 +1111,11 @@
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_ExternalToUtfDStringEx(
- NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL);
+ NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL);
return Tcl_DStringValue(dstPtr);
}
/*
*-------------------------------------------------------------------------
@@ -2501,14 +2507,14 @@
}
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/*
* Incomplete byte sequence.
- * Always check before using Tcl_UtfToUniChar. Not doing so can cause
+ * Always check before using Tcl_UtfToUniChar. Not doing can so cause
* it to run beyond the end of the buffer! If we happen on such an
- * incomplete char its bytes are made to represent themselves unless
- * the user has explicitly asked to be told.
+ * incomplete char its bytes are made to represent themselves
+ * unless the user has explicitly asked to be told.
*/
if (flags & ENCODING_INPUT) {
/* Incomplete bytes for modified UTF-8 target */
if (PROFILE_STRICT(profile)) {
@@ -3592,11 +3598,10 @@
break;
}
/*
* Plunge on, using '?' as a fallback character.
*/
-
ch = '?'; /* Profiles TCL8 and REPLACE */
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
@@ -4266,11 +4271,11 @@
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = TclGetStringFromObj(searchPathObj, &numBytes);
+ bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
*lengthPtr = numBytes;
*valuePtr = (char *)Tcl_Alloc(numBytes + 1);
memcpy(*valuePtr, bytes, numBytes + 1);
Tcl_DecrRefCount(searchPathObj);
Index: generic/tclEnsemble.c
==================================================================
--- generic/tclEnsemble.c
+++ generic/tclEnsemble.c
@@ -1,17 +1,28 @@
/*
- * tclEnsemble.c --
- *
- * Contains support for ensembles (see TIP#112), which provide simple
- * mechanism for creating composite commands on top of namespaces.
- *
* 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:
@@ -80,11 +91,11 @@
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define ECRSetInternalRep(objPtr, ecRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -310,11 +321,21 @@
Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
+ patchedDict = TclDuplicatePureObj(
+ interp, objv[1], tclDictTypePtr);
+ if (!patchedDict) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ Tcl_DecrRefCount(newList);
+ Tcl_DecrRefCount(newCmd);
+ Tcl_DecrRefCount(patchedDict);
+ return TCL_ERROR;
+ }
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
@@ -594,21 +615,32 @@
}
goto freeMapAndError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
- Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
+ Tcl_Obj *newList = TclDuplicatePureObj(
+ interp, listObj, tclListTypePtr);
+ if (!newList) {
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", (void *)NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
&newCmd);
if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
+ patchedDict = TclDuplicatePureObj(
+ interp, objv[1], tclListTypePtr);
+ if (!patchedDict) {
+ goto freeMapAndError;
+ }
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
@@ -1822,11 +1854,11 @@
char *fullName = NULL; /* Full name of the subcommand. */
Tcl_Size stringLength, i;
Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
- subcmdName = TclGetStringFromObj(subObj, &stringLength);
+ subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
for (i=0 ; isubcommandArrayPtr[i],
stringLength);
@@ -1901,11 +1933,15 @@
Tcl_Size copyObjc, prefixObjc;
TclListObjLength(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
- copyPtr = TclListObjCopy(NULL, prefixObj);
+ 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);
@@ -2301,11 +2337,15 @@
/*
* Create the "unknown" command callback to determine what to do.
*/
- unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
+ 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]);
@@ -3003,11 +3043,11 @@
if (TclListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto tryCompileToInv;
}
for (i=0 ; itokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i <= numWords) {
- bytes = TclGetStringFromObj(words[i-1], &length);
+ bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
continue;
}
SetLineInformation(i);
@@ -3436,11 +3476,11 @@
* the implementation.
*/
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = TclGetStringFromObj(objPtr, &length);
+ 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);
Index: generic/tclEnv.c
==================================================================
--- generic/tclEnv.c
+++ generic/tclEnv.c
@@ -1,18 +1,29 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
Index: generic/tclEvent.c
==================================================================
--- generic/tclEvent.c
+++ generic/tclEvent.c
@@ -1,20 +1,31 @@
/*
- * tclEvent.c --
- *
- * This file implements some general event related interfaces including
- * background errors, exit handlers, and the "vwait" and "update" command
- * functions.
- *
* 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"
/*
* The data structure below is used to report background errors. One such
@@ -232,11 +243,15 @@
/*
* Note we copy the handler command prefix each pass through, so we do
* support one handler setting another handler.
*/
- Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
+ 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 *));
@@ -1089,13 +1104,10 @@
".msvc-" STRINGIFY(_MSC_VER)
#endif
#ifdef USE_NMAKE
".nmake"
#endif
-#ifdef TCL_NO_DEPRECATED
- ".no-deprecate"
-#endif
#if !TCL_THREADS
".no-thread"
#endif
#ifndef TCL_CFG_OPTIMIZED
".no-optimize"
@@ -1157,10 +1169,14 @@
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();
subsystemsInitialized = 1;
}
TclpInitUnlock();
}
TclInitNotifier();
Index: generic/tclExecute.c
==================================================================
--- generic/tclExecute.c
+++ generic/tclExecute.c
@@ -1,22 +1,34 @@
/*
- * tclExecute.c --
- *
- * This file contains procedures that execute byte-compiled Tcl commands.
- *
* 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
* 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
@@ -448,15 +460,15 @@
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* void **ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType)) \
+ ((TclHasInternalRep((objPtr), tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
- TclHasInternalRep((objPtr), &tclDoubleType) \
+ TclHasInternalRep((objPtr), tclDoubleType) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
@@ -660,11 +672,11 @@
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
/*
* Custom object type only used in this file; values of its type should never
* be seen by user scripts.
@@ -672,11 +684,11 @@
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
ReleaseDictIterator,
NULL, NULL, NULL,
- TCL_OBJTYPE_V0
+ 0
};
/*
*----------------------------------------------------------------------
*
@@ -916,11 +928,11 @@
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
}
/*
- * Auxiliary code to insure that GrowEvaluationStack always returns correctly
+ * 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,11 +1446,11 @@
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
Tcl_Size length;
- const char *string = TclGetStringFromObj(objPtr, &length);
+ const char *string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
TclCompileExpr(interp, string, length, &compEnv, 0);
/*
@@ -1478,20 +1490,20 @@
*----------------------------------------------------------------------
*
* DupExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
- * bytecode. We do not copy the bytecode internalrep. Instead, we return
+ * 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 internalrep,
+ * we had some modifying routines that operated directly on the intrep,
* like we do for lists and dicts.
*
* Results:
* None.
*
@@ -3374,11 +3386,20 @@
if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
- Tcl_Obj *newValue = Tcl_DuplicateObj(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);
}
@@ -3433,11 +3454,17 @@
} else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
- valueToAssign = Tcl_DuplicateObj(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,
@@ -4401,21 +4428,25 @@
origCmd = cmd;
}
TclNewObj(objResultPtr);
Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
- if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) {
- Tcl_DecrRefCount(objResultPtr);
- instOriginError:
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
- DECACHE_STACK_INFO();
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(OBJ_AT_TOS), (void *)NULL);
- CACHE_STACK_INFO();
- TRACE_APPEND(("ERROR: not command\n"));
- goto gotError;
+ {
+ 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), (void *)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);
}
@@ -4700,11 +4731,12 @@
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
- int numIndices, nocase, match, cflags;
+ int dstatus, numIndices, nocase, match, cflags,
+ toIdxAnchor, fromIdxAnchor;
Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
/*
@@ -4729,70 +4761,88 @@
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;
+ }
+ }
- /* special case for AbstractList */
- if (TclObjTypeHasProc(valuePtr,indexProc)) {
+ 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();
- length = TclObjTypeLength(valuePtr);
- if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
- CACHE_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 (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
- CACHE_STACK_INFO();
- 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.
*/
-
- {
- Tcl_Size value2Length;
- Tcl_Obj *indexListPtr = value2Ptr;
-
- if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
- && (!TclHasInternalRep(value2Ptr, &tclListType)
- || (Tcl_ListObjLength(interp, value2Ptr, &value2Length),
- value2Length == 1
- ? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1)
- : 0))) {
- int code;
-
- /* increment the refCount of value2Ptr because TclListObjGetElement may
- * have just extracted it from a list in the condition for this block.
- */
- Tcl_IncrRefCount(indexListPtr);
-
- DECACHE_STACK_INFO();
- code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index);
- TclDecrRefCount(indexListPtr);
- CACHE_STACK_INFO();
- if (code == TCL_OK) {
- Tcl_DecrRefCount(value2Ptr);
- tosPtr--;
- pcAdjustment = 1;
- goto lindexFastPath;
- }
- Tcl_ResetResult(interp);
- }
- }
-
- DECACHE_STACK_INFO();
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
CACHE_STACK_INFO();
lindexDone:
if (!objResultPtr) {
@@ -4815,50 +4865,87 @@
*/
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.
*/
- /* special case for AbstractList */
- if (TclObjTypeHasProc(valuePtr,indexProc)) {
- length = TclObjTypeLength(valuePtr);
-
- /* Decode end-offset index values. */
- index = TclIndexDecode(opnd, length-1);
-
- if (index >= 0 && index < length) {
- /* Compute value @ index */
- DECACHE_STACK_INFO();
- if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
- }
- CACHE_STACK_INFO();
- } else {
- TclNewObj(objResultPtr);
- }
-
- pcAdjustment = 5;
- goto lindexFastPath2;
- }
-
- /* List case */
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
- TRACE_ERROR(interp);
- goto gotError;
- }
-
- /* Decode end-offset index values. */
-
- index = TclIndexDecode(opnd, objc - 1);
- pcAdjustment = 5;
+ 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 {
@@ -4919,30 +5006,28 @@
/*
* Compute the new variable value.
*/
DECACHE_STACK_INFO();
- if (TclObjTypeHasProc(valuePtr, setElementProc)) {
- objResultPtr = TclObjTypeSetElement(interp,
- valuePtr, numIndices,
- &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
- } else {
- objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
- &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
- }
- if (!objResultPtr) {
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
+ {
+ 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);
+ 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
@@ -4975,11 +5060,11 @@
/*
* Set result.
*/
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, -1);
+ NEXT_INST_F(1, 2, 1);
case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
* bytecode stream */
/*
@@ -5029,41 +5114,50 @@
emptyList:
TclNewObj(objResultPtr);
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
}
- toIdx = TclIndexDecode(toIdx, objc - 1);
- if (toIdx == TCL_INDEX_NONE) {
- goto emptyList;
- } else if (toIdx >= objc) {
- toIdx = objc - 1;
- }
-
- assert (toIdx >= 0 && 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);
+
+ toIdxAnchor = TclIndexIsFromEnd(toIdx);
+ fromIdxAnchor = TclIndexIsFromEnd(fromIdx);
DECACHE_STACK_INFO();
- if (TclObjTypeHasProc(valuePtr, sliceProc)) {
- if (TclObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) {
- objResultPtr = NULL;
+ 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 {
- objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx);
- }
- if (objResultPtr == NULL) {
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
+ 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);
@@ -5071,64 +5165,61 @@
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
- s1 = TclGetStringFromObj(valuePtr, &s1len);
- TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+ s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
- if (TclObjTypeHasProc(value2Ptr,inOperProc) != NULL) {
- int status = TclObjTypeInOperator(interp, valuePtr, value2Ptr, &match);
+ 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 {
-
- if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
- TRACE_ERROR(interp);
- goto gotError;
- }
- match = 0;
- if (length > 0) {
- Tcl_Size i = 0;
- Tcl_Obj *o;
- int isAbstractList = TclObjTypeHasProc(value2Ptr,indexProc) != NULL;
-
- /*
- * An empty list doesn't match anything.
- */
-
- do {
- if (isAbstractList) {
- DECACHE_STACK_INFO();
- if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) {
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
- }
- CACHE_STACK_INFO();
- } else {
- Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
- }
- if (o != NULL) {
- s2 = TclGetStringFromObj(o, &s2len);
- } else {
- s2 = "";
- s2len = 0;
- }
- if (s1len == s2len) {
- match = (memcmp(s1, s2, s1len) == 0);
- }
-
- /* Could be an ephemeral abstract obj */
- Tcl_BounceRefCount(o);
-
- i++;
- } while (i < length && match == 0);
- }
- }
+ } 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;
}
@@ -5196,11 +5287,11 @@
&fromIdx) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
- if (fromIdx == TCL_INDEX_NONE) {
+ if (fromIdx < 0) {
fromIdx = 0;
} else if (fromIdx > length) {
fromIdx = length;
}
numToDelete = 0;
@@ -5214,11 +5305,11 @@
if (toIdx != TCL_INDEX_NONE) {
if (toIdx > length) {
toIdx = length;
}
if (toIdx >= fromIdx) {
- numToDelete = (size_t)toIdx - (size_t)fromIdx + 1;
+ numToDelete = toIdx - fromIdx + 1;
}
}
}
CACHE_STACK_INFO();
@@ -5318,11 +5409,11 @@
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
- s1 = TclGetStringFromObj(valuePtr, &slength);
+ 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);
@@ -5335,11 +5426,11 @@
}
case INST_STR_LOWER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
- s1 = TclGetStringFromObj(valuePtr, &slength);
+ 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);
@@ -5352,11 +5443,11 @@
}
case INST_STR_TITLE:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
- s1 = TclGetStringFromObj(valuePtr, &slength);
+ 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);
@@ -5376,43 +5467,51 @@
/*
* Get char length to calculate what 'end' means.
*/
slength = Tcl_GetCharLength(valuePtr);
- 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, (Tcl_Size *)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);
- }
- }
-
+ 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 =>",
@@ -5451,18 +5550,78 @@
if (slength == 0) {
TRACE_APPEND(("\n"));
NEXT_INST_F(9, 0, 0);
}
- /* Decode index operands. */
+ if (TclObjectHasInterface(valuePtr, list, index)) {
+ if ((TclIndexIsFromEnd(toIdx) || TclIndexIsFromEnd(fromIdx))
+ && !Tcl_LengthIsFinite(slength)) {
- toIdx = TclIndexDecode(toIdx, slength - 1);
- fromIdx = TclIndexDecode(fromIdx, slength - 1);
- if (toIdx == TCL_INDEX_NONE) {
- TclNewObj(objResultPtr);
+ 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 {
- objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
+ /* 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);
{
@@ -5671,28 +5830,28 @@
Tcl_Size trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
- string2 = TclGetStringFromObj(value2Ptr, &length2);
- string1 = TclGetStringFromObj(valuePtr, &slength);
+ 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 = TclGetStringFromObj(value2Ptr, &length2);
- string1 = TclGetStringFromObj(valuePtr, &slength);
+ 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 = TclGetStringFromObj(value2Ptr, &length2);
- string1 = TclGetStringFromObj(valuePtr, &slength);
+ 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]
@@ -5783,21 +5942,33 @@
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE: {
- int iResult = 0, compare = 0;
+ 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.
*/
- if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) {
+ 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) {
/*
@@ -6415,11 +6586,11 @@
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 internalrep, but not the string, so we temporarily hide
+ * to copy the intrep, but not the string, so we temporarily hide
* the string so we do not copy it.
*/
char *savedString = valuePtr->bytes;
@@ -6440,11 +6611,11 @@
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
- if (TclHasInternalRep(valuePtr, &tclBooleanType)) {
+ if (TclHasInternalRep(valuePtr, tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(res);
}
@@ -6509,11 +6680,17 @@
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
- objPtr = TclListObjCopy(NULL, 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;
@@ -6583,16 +6760,14 @@
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
- int hasAbstractList;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
- hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0;
DECACHE_STACK_INFO();
- if (hasAbstractList) {
+ if (TclObjectHasInterface(listPtr, list, index)) {
status = Tcl_ListObjLength(interp, listPtr, &listLen);
elements = NULL;
} else {
status = TclListObjGetElements(
interp, listPtr, &listLen, &elements);
@@ -6599,12 +6774,10 @@
}
if (status != TCL_OK) {
CACHE_STACK_INFO();
goto gotError;
}
- CACHE_STACK_INFO();
-
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
@@ -7144,11 +7317,11 @@
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 internalrep of an iterator. We need
+ * moving it into the intrep of an iterator. We need
* to drop the refcount [Tcl Bug 9b352768e6].
*/
Tcl_DecrRefCount(dictPtr);
Tcl_Free(searchPtr);
@@ -7757,14 +7930,14 @@
TclStackFree(interp, TD); /* free my stack */
return result;
/*
- * INST_START_CMD failure case removed where it doesn't bother that much
+ * INST_START_CMD failure case removed where it doesn't bother that much.
*
- * Remark that if the interpreter is marked for deletion its
- * compileEpoch is modified, so that the epoch check also verifies
+ * 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:
*/
@@ -8491,11 +8664,11 @@
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
- || !TclHasInternalRep(value2Ptr, &tclIntType)
+ || !TclHasInternalRep(value2Ptr, tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
@@ -9733,11 +9906,11 @@
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
- (void) TclGetStringFromObj(entryPtr->objPtr, &length);
+ (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++;
@@ -9959,11 +10132,11 @@
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
- char *str = TclGetStringFromObj(objv[1], &length);
+ 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) {
Index: generic/tclFCmd.c
==================================================================
--- generic/tclFCmd.c
+++ generic/tclFCmd.c
@@ -1,17 +1,28 @@
/*
- * tclFCmd.c
- *
- * This file implements the generic portion of file manipulation
- * subcommands of the "file" command.
- *
* 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:
@@ -1444,11 +1455,11 @@
TclNewObj(nameObj);
}
if (objc > 2) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[2];
- const char *string = TclGetStringFromObj(templateObj, &length);
+ const char *string = Tcl_GetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
@@ -1596,11 +1607,11 @@
}
if (objc > 1) {
Tcl_Size length;
Tcl_Obj *templateObj = objv[1];
- const char *string = TclGetStringFromObj(templateObj, &length);
+ const char *string = Tcl_GetStringFromObj(templateObj, &length);
const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
/*
* Treat an empty string as if it wasn't there.
*/
Index: generic/tclFileName.c
==================================================================
--- generic/tclFileName.c
+++ generic/tclFileName.c
@@ -1,18 +1,29 @@
/*
- * tclFileName.c --
- *
- * This file contains routines for converting file names betwen native
- * and network form.
- *
* 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() */
/*
@@ -548,11 +559,11 @@
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- (void)TclGetStringFromObj(eltPtr, &len);
+ (void)Tcl_GetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
@@ -568,11 +579,11 @@
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
- str = TclGetStringFromObj(eltPtr, &len);
+ str = Tcl_GetStringFromObj(eltPtr, &len);
memcpy(p, str, len + 1);
p += len+1;
}
/*
@@ -810,11 +821,11 @@
Tcl_Size length;
char *dest;
const char *p;
const char *start;
- start = TclGetStringFromObj(prefix, &length);
+ start = Tcl_GetStringFromObj(prefix, &length);
/*
* Remove the ./ from drive-letter prefixed
* elements on Windows, unless it is the first component.
*/
@@ -838,11 +849,11 @@
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
- (void)TclGetStringFromObj(prefix, &length);
+ (void)Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
@@ -874,11 +885,11 @@
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
- (void)TclGetStringFromObj(prefix, &length);
+ (void)Tcl_GetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
@@ -957,11 +968,11 @@
/*
* Store the result.
*/
- resultStr = TclGetStringFromObj(resultObj, &len);
+ resultStr = Tcl_GetStringFromObj(resultObj, &len);
Tcl_DStringAppend(resultPtr, resultStr, len);
Tcl_DecrRefCount(resultObj);
/*
* Return a pointer to the result.
@@ -1257,11 +1268,11 @@
}
if (dir == PATH_GENERAL) {
Tcl_Size pathlength;
const char *last;
- const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
+ const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
@@ -1364,11 +1375,11 @@
while (length-- > 0) {
Tcl_Size len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
- str = TclGetStringFromObj(look, &len);
+ 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) {
@@ -1808,11 +1819,11 @@
if (pathPrefix == NULL) {
Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
}
- pre = TclGetStringFromObj(pathPrefix, &prefixLen);
+ 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
@@ -1826,11 +1837,11 @@
}
TclListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
Tcl_Size len;
- const char *oldStr = TclGetStringFromObj(objv[i], &len);
+ const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
@@ -2169,11 +2180,11 @@
const char *bytes;
Tcl_Size numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
- bytes = TclGetStringFromObj(fixme, &numBytes);
+ bytes = Tcl_GetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
repair++;
}
@@ -2207,11 +2218,11 @@
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
if (pathPtr != NULL) {
- (void) TclGetStringFromObj(pathPtr, &length);
+ (void) Tcl_GetStringFromObj(pathPtr, &length);
} else {
length = 0;
}
switch (tclPlatform) {
@@ -2253,11 +2264,11 @@
/*
* The current prefix must end in a separator.
*/
Tcl_Size len;
- const char *joined = TclGetStringFromObj(joinedPtr,&len);
+ const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
@@ -2290,11 +2301,11 @@
* //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 = TclGetStringFromObj(joinedPtr,&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);
}
Index: generic/tclFileSystem.h
==================================================================
--- generic/tclFileSystem.h
+++ generic/tclFileSystem.h
@@ -1,17 +1,28 @@
/*
- * tclFileSystem.h --
- *
- * This file contains the common definitions and prototypes for use by
- * Tcl's filesystem and path handling layers.
- *
* 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"
Index: generic/tclGet.c
==================================================================
--- generic/tclGet.c
+++ generic/tclGet.c
@@ -1,19 +1,30 @@
/*
- * 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.
- *
* 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"
/*
*----------------------------------------------------------------------
*
Index: generic/tclGetDate.y
==================================================================
--- generic/tclGetDate.y
+++ generic/tclGetDate.y
@@ -1,20 +1,30 @@
+/*
+ * 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.
- *
- * Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
- * Copyright © 1995-1997 Sun Microsystems, Inc.
- * Copyright © 2015 Sergey G. Brester aka sebres.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
%parse-param {DateInfo* info}
%lex-param {DateInfo* info}
%define api.pure
@@ -26,18 +36,27 @@
* tclDate.c --
*
* This file is generated from a yacc grammar defined in the file
* tclGetDate.y. It should not be edited directly.
*
- * Copyright © 1992-1995 Karl Lehenbauer & Mark Diekhans.
- * Copyright © 1995-1997 Sun Microsystems, Inc.
- * Copyright © 2015 Sergey G. Brester aka sebres.
+ * 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.
@@ -45,24 +64,90 @@
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
-#if 0
-#define YYDEBUG 1
-#endif
+/*
+ * 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.
*/
-#include "tclDate.h"
+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
/*
@@ -70,28 +155,22 @@
* Posix requires 1900.
*/
#define TM_YEAR_BASE 1900
-#define HOUR(x) ((60 * (int)(x)))
+#define HOUR(x) ((int) (60 * (x)))
+#define SECSPERDAY (24L * 60L * 60L)
#define IsLeapYear(x) (((x) % 4 == 0) && ((x) % 100 != 0 || (x) % 400 == 0))
-#define yyIncrFlags(f) \
- do { \
- info->errFlags |= (info->flags & (f)); \
- if (info->errFlags) { YYABORT; } \
- info->flags |= (f); \
- } while (0);
-
/*
* An entry in the lexical lookup table.
*/
-typedef struct {
+typedef struct _TABLE {
const char *name;
int type;
- int value;
+ time_t value;
} TABLE;
/*
* Daylight-savings mode: on, off, or not yet known.
*/
@@ -101,11 +180,11 @@
} DSTMODE;
%}
%union {
- Tcl_WideInt Number;
+ time_t Number;
enum _MERIDIAN Meridian;
}
%{
@@ -112,14 +191,16 @@
/*
* Prototypes of internal functions.
*/
static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
-static void TclDateerror(YYLTYPE* location,
+ static void TclDateerror(YYLTYPE* location,
DateInfo* info, const char *s);
-static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
+ 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
@@ -129,37 +210,29 @@
%token tMERIDIAN
%token tMONTH
%token tMONTH_UNIT
%token tSTARDATE
%token tSEC_UNIT
+%token tSNUMBER
%token tUNUMBER
%token tZONE
-%token tZONEwO4
-%token tZONEwO2
%token tEPOCH
%token tDST
-%token tISOBAS8
-%token tISOBAS6
-%token tISOBASL
+%token tISOBASE
%token tDAY_UNIT
%token tNEXT
-%token SP
%type tDAY
%type tDAYZONE
%type tMONTH
%type tMONTH_UNIT
%type tDST
%type tSEC_UNIT
+%type tSNUMBER
%type tUNUMBER
-%type INTNUM
%type tZONE
-%type tZONEwO4
-%type tZONEwO2
-%type tISOBAS8
-%type tISOBAS6
-%type tISOBASL
+%type tISOBASE
%type tDAY_UNIT
%type unit
%type sign
%type tNEXT
%type tSTARDATE
@@ -168,145 +241,133 @@
%%
spec : /* NULL */
| spec item
- /* | spec SP item */
;
item : time {
- yyIncrFlags(CLF_TIME);
+ yyHaveTime++;
}
| zone {
- yyIncrFlags(CLF_ZONE);
+ yyHaveZone++;
}
| date {
- yyIncrFlags(CLF_HAVEDATE);
+ yyHaveDate++;
}
| ordMonth {
- yyIncrFlags(CLF_ORDINALMONTH);
+ yyHaveOrdinalMonth++;
}
| day {
- yyIncrFlags(CLF_DAYOFWEEK);
+ yyHaveDay++;
}
| relspec {
- info->flags |= CLF_RELCONV;
+ yyHaveRel++;
}
| iso {
- yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
+ yyHaveTime++;
+ yyHaveDate++;
}
| trek {
- yyIncrFlags(CLF_TIME|CLF_HAVEDATE);
- info->flags |= CLF_RELCONV;
- }
- | numitem
- ;
-
-iextime : tUNUMBER ':' tUNUMBER ':' tUNUMBER {
- yyHour = $1;
- yyMinutes = $3;
- yySeconds = $5;
- }
- | tUNUMBER ':' tUNUMBER {
- yyHour = $1;
- yyMinutes = $3;
- yySeconds = 0;
- }
- ;
+ yyHaveTime++;
+ yyHaveDate++;
+ yyHaveRel++;
+ }
+ | number
+ ;
+
time : tUNUMBER tMERIDIAN {
yyHour = $1;
yyMinutes = 0;
yySeconds = 0;
yyMeridian = $2;
}
- | iextime o_merid {
- 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;
}
- | tZONEwO4 sign INTNUM { /* GMT+0100, GMT-1000, etc. */
- yyTimezone = $1 - $2*($3 % 100 + ($3 / 100) * 60);
- yyDSTmode = DSToff;
- }
- | tZONEwO2 sign INTNUM { /* GMT+1, GMT-10, etc. */
- yyTimezone = $1 - $2*($3 * 60);
- yyDSTmode = DSToff;
- }
- | sign INTNUM { /* +0100, -0100 */
+ | sign tUNUMBER {
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
yyDSTmode = DSToff;
}
;
-comma : ','
- | ',' SP
- ;
-
day : tDAY {
yyDayOrdinal = 1;
- yyDayOfWeek = $1;
+ yyDayNumber = $1;
}
- | tDAY comma {
+ | tDAY ',' {
yyDayOrdinal = 1;
- yyDayOfWeek = $1;
+ yyDayNumber = $1;
}
| tUNUMBER tDAY {
yyDayOrdinal = $1;
- yyDayOfWeek = $2;
- }
- | sign SP tUNUMBER tDAY {
- yyDayOrdinal = $1 * $3;
- yyDayOfWeek = $4;
+ yyDayNumber = $2;
}
| sign tUNUMBER tDAY {
yyDayOrdinal = $1 * $2;
- yyDayOfWeek = $3;
+ yyDayNumber = $3;
}
| tNEXT tDAY {
yyDayOrdinal = 2;
- yyDayOfWeek = $2;
+ yyDayNumber = $2;
}
;
-iexdate : tUNUMBER '-' tUNUMBER '-' tUNUMBER {
- yyMonth = $3;
- yyDay = $5;
- yyYear = $1;
- }
- ;
date : tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
}
| tUNUMBER '/' tUNUMBER '/' tUNUMBER {
yyMonth = $1;
yyDay = $3;
yyYear = $5;
}
- | isodate
+ | 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 comma tUNUMBER {
+ | tMONTH tUNUMBER ',' tUNUMBER {
yyMonth = $1;
yyDay = $2;
yyYear = $4;
}
| tUNUMBER tMONTH {
@@ -324,71 +385,68 @@
yyYear = $3;
}
;
ordMonth: tNEXT tMONTH {
- yyMonthOrdinalIncr = 1;
- yyMonthOrdinal = $2;
- }
- | tNEXT tUNUMBER tMONTH {
- yyMonthOrdinalIncr = $2;
- yyMonthOrdinal = $3;
- }
- ;
-
-isosep : 'T'|SP
- ;
-isodate : tISOBAS8 { /* YYYYMMDD */
- yyYear = $1 / 10000;
- yyMonth = ($1 % 10000)/100;
- yyDay = $1 % 100;
- }
- | tISOBAS6 { /* YYMMDD */
- yyYear = $1 / 10000;
- yyMonth = ($1 % 10000)/100;
- yyDay = $1 % 100;
- }
- | iexdate
- ;
-isotime : tISOBAS6 {
- yyHour = $1 / 10000;
- yyMinutes = ($1 % 10000)/100;
- yySeconds = $1 % 100;
- }
- | iextime
- ;
-iso : isodate isosep isotime
- | tISOBASL tISOBAS6 { /* YYYYMMDDhhmmss */
+ 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;
}
- | tISOBASL tUNUMBER { /* YYYYMMDDhhmm */
- if (yyDigitCount != 4) YYABORT; /* normally unreached */
- yyYear = $1 / 10000;
- yyMonth = ($1 % 10000)/100;
- yyDay = $1 % 100;
- yyHour = $2 / 100;
- yyMinutes = ($2 % 100);
- yySeconds = 0;
- }
;
-trek : tSTARDATE INTNUM '.' tUNUMBER {
+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 * (144LL * 60LL);
+ yyRelSeconds += $4 * 144 * 60;
}
;
relspec : relunits tAGO {
yyRelSeconds *= -1;
@@ -396,23 +454,20 @@
yyRelDay *= -1;
}
| relunits
;
-relunits : sign SP INTNUM unit {
- *yyRelPointer += $1 * $3 * $4;
- }
- | sign INTNUM unit {
+relunits : sign tUNUMBER unit {
*yyRelPointer += $1 * $2 * $3;
}
- | INTNUM unit {
+ | tUNUMBER unit {
*yyRelPointer += $1 * $2;
}
| tNEXT unit {
*yyRelPointer += $2;
}
- | tNEXT INTNUM unit {
+ | tNEXT tUNUMBER unit {
*yyRelPointer += $2 * $3;
}
| unit {
*yyRelPointer += $1;
}
@@ -438,26 +493,15 @@
$$ = $1;
yyRelPointer = &yyRelMonth;
}
;
-INTNUM : tUNUMBER {
- $$ = $1;
- }
- | tISOBAS6 {
- $$ = $1;
- }
- | tISOBAS8 {
- $$ = $1;
- }
- ;
-
-numitem : tUNUMBER {
- if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) {
+number : tUNUMBER {
+ if (yyHaveTime && yyHaveDate && !yyHaveRel) {
yyYear = $1;
} else {
- yyIncrFlags(CLF_TIME);
+ yyHaveTime++;
if (yyDigitCount <= 2) {
yyHour = $1;
yyMinutes = 0;
} else {
yyHour = $1 / 100;
@@ -538,10 +582,24 @@
{ "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 }
};
@@ -637,48 +695,38 @@
/*
* Military timezone table.
*/
static const TABLE MilitaryTable[] = {
- { "a", tZONE, -HOUR( 1) },
- { "b", tZONE, -HOUR( 2) },
- { "c", tZONE, -HOUR( 3) },
- { "d", tZONE, -HOUR( 4) },
- { "e", tZONE, -HOUR( 5) },
- { "f", tZONE, -HOUR( 6) },
- { "g", tZONE, -HOUR( 7) },
- { "h", tZONE, -HOUR( 8) },
- { "i", tZONE, -HOUR( 9) },
- { "k", tZONE, -HOUR(10) },
- { "l", tZONE, -HOUR(11) },
- { "m", tZONE, -HOUR(12) },
- { "n", tZONE, HOUR( 1) },
- { "o", tZONE, HOUR( 2) },
- { "p", tZONE, HOUR( 3) },
- { "q", tZONE, HOUR( 4) },
- { "r", tZONE, HOUR( 5) },
- { "s", tZONE, HOUR( 6) },
- { "t", tZONE, HOUR( 7) },
- { "u", tZONE, HOUR( 8) },
- { "v", tZONE, HOUR( 9) },
- { "w", tZONE, HOUR( 10) },
- { "x", tZONE, HOUR( 11) },
- { "y", tZONE, HOUR( 12) },
- { "z", tZONE, HOUR( 0) },
+ { "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 }
};
-static inline const char *
-bypassSpaces(
- const char *s)
-{
- while (TclIsSpaceProc(*s)) {
- s++;
- }
- return s;
-}
-
/*
* Dump error messages in the bit bucket.
*/
static void
@@ -686,13 +734,10 @@
YYLTYPE* location,
DateInfo* infoPtr,
const char *s)
{
Tcl_Obj* t;
- if (!infoPtr->messages) {
- TclNewObj(infoPtr->messages);
- }
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);
@@ -705,15 +750,15 @@
Tcl_DecrRefCount(t);
Tcl_AppendToObj(infoPtr->messages, ")", -1);
infoPtr->separatrix = "\n";
}
-int
+static time_t
ToSeconds(
- int Hours,
- int Minutes,
- int Seconds,
+ time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
MERIDIAN Meridian)
{
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) {
return -1;
}
@@ -720,21 +765,21 @@
switch (Meridian) {
case MER24:
if (Hours < 0 || Hours > 23) {
return -1;
}
- return (Hours * 60 + Minutes) * 60 + Seconds;
+ return (Hours * 60L + Minutes) * 60L + Seconds;
case MERam:
if (Hours < 1 || Hours > 12) {
return -1;
}
- return ((Hours % 12) * 60 + Minutes) * 60 + Seconds;
+ return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
case MERpm:
if (Hours < 1 || Hours > 12) {
return -1;
}
- return (((Hours % 12) + 12) * 60 + Minutes) * 60 + Seconds;
+ return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
}
return -1; /* Should never be reached */
}
static int
@@ -751,15 +796,15 @@
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
- if (*buff == 'a' && (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0)) {
+ if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylvalPtr->Meridian = MERam;
return tMERIDIAN;
}
- if (*buff == 'p' && (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0)) {
+ if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
yylvalPtr->Meridian = MERpm;
return tMERIDIAN;
}
/*
@@ -869,114 +914,54 @@
{
char c;
char *p;
char buff[20];
int Count;
- const char *tokStart;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
-
- if (isspace(UCHAR(*yyInput))) {
- yyInput = bypassSpaces(yyInput);
- /* ignore space at end of text and before some words */
- c = *yyInput;
- if (c != '\0' && !isalpha(UCHAR(c))) {
- return SP;
- }
- }
- tokStart = yyInput;
+ while (TclIsSpaceProcM(*yyInput)) {
+ yyInput++;
+ }
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
-
- /*
- * Count the number of digits.
- */
- p = (char *)yyInput;
- while (isdigit(UCHAR(*++p))) {};
- yyDigitCount = p - yyInput;
- /*
- * A number with 12 or 14 digits is considered an ISO 8601 date.
- */
- if (yyDigitCount == 14 || yyDigitCount == 12) {
- /* long form of ISO 8601 (without separator), either
- * YYYYMMDDhhmmss or YYYYMMDDhhmm, so reduce to date
- * (8 chars is isodate) */
- p = (char *)yyInput+8;
- if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
- return tID; /* overflow*/
- }
- yyDigitCount = 8;
- yyInput = p;
- location->last_column = yyInput - info->dateStart - 1;
- return tISOBASL;
- }
- /*
- * Convert the string into a number
- */
- if (TclAtoWIe(&yylvalPtr->Number, yyInput, p, 1) != TCL_OK) {
- return tID; /* overflow*/
- }
- yyInput = p;
+ /*
+ * 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.
*/
- location->last_column = yyInput - info->dateStart - 1;
- if (yyDigitCount >= 6) {
- if (yyDigitCount == 8) {
- return tISOBAS8;
- }
- if (yyDigitCount == 6) {
- return tISOBAS6;
- }
- }
- /* ignore spaces after digits (optional) */
- yyInput = bypassSpaces(yyInput);
- return tUNUMBER;
+
+ 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. */
- int ret;
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|| c == '.'; ) {
- if (p < &buff[sizeof(buff) - 1]) {
+ if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
}
*p = '\0';
yyInput--;
location->last_column = yyInput - info->dateStart - 1;
- ret = LookupWord(yylvalPtr, buff);
- /*
- * lookahead:
- * for spaces to consider word boundaries (for instance
- * literal T in isodateTisotimeZ is not a TZ, but Z is UTC);
- * for +/- digit, to differentiate between "GMT+1000 day" and "GMT +1000 day";
- * bypass spaces after token (but ignore by TZ+OFFS), because should
- * recognize next SP token, if TZ only.
- */
- if (ret == tZONE || ret == tDAYZONE) {
- c = *yyInput;
- if (isdigit(UCHAR(c))) { /* literal not a TZ */
- yyInput = tokStart;
- return *yyInput++;
- }
- if ((c == '+' || c == '-') && isdigit(UCHAR(*(yyInput+1)))) {
- if ( !isdigit(UCHAR(*(yyInput+2)))
- || !isdigit(UCHAR(*(yyInput+3)))) {
- /* GMT+1, GMT-10, etc. */
- return tZONEwO2;
- }
- if ( isdigit(UCHAR(*(yyInput+4)))
- && !isdigit(UCHAR(*(yyInput+5)))) {
- /* GMT+1000, etc. */
- return tZONEwO4;
- }
- }
- }
- yyInput = bypassSpaces(yyInput);
- return ret;
-
+ return LookupWord(yylvalPtr, buff);
}
if (c != '(') {
location->last_column = yyInput - info->dateStart;
return *yyInput++;
}
@@ -992,83 +977,177 @@
Count--;
}
} while (Count > 0);
}
}
-
+
int
-TclClockFreeScan(
+TclClockOldscanObjCmd(
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
- DateInfo *info) /* Input and result parameters */
+ 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 YYDEBUG
- /* enable debugging if compiled with YYDEBUG */
- yydebug = 1;
- #endif
-
- /*
- * yyInput = stringToParse;
- *
- * ClockInitDateInfo(info) should be executed to pre-init info;
- */
-
- yyDSTmode = DSTmaybe;
-
- info->separatrix = "";
-
- info->dateStart = yyInput;
-
- /* ignore spaces at begin */
- yyInput = bypassSpaces(yyInput);
-
- /* parse */
- status = yyparse(info);
+ 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) {
- const char *msg = NULL;
- if (info->errFlags & CLF_HAVEDATE) {
- msg = "more than one date in string";
- } else if (info->errFlags & CLF_TIME) {
- msg = "more than one time of day in string";
- } else if (info->errFlags & CLF_ZONE) {
- msg = "more than one time zone in string";
- } else if (info->errFlags & CLF_DAYOFWEEK) {
- msg = "more than one weekday in string";
- } else if (info->errFlags & CLF_ORDINALMONTH) {
- msg = "more than one ordinal month in string";
- }
- if (msg) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", (char *)NULL);
- } else {
- Tcl_SetObjResult(interp,
- info->messages ? info->messages : Tcl_NewObj());
- info->messages = NULL;
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", (char *)NULL);
- }
- status = TCL_ERROR;
+ 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);
- status = TCL_ERROR;
+ 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);
- status = TCL_ERROR;
+ 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));
}
- if (info->messages) {
- Tcl_DecrRefCount(info->messages);
+ Tcl_ListObjAppendElement(interp, result, resultElement);
+
+ TclNewObj(resultElement);
+ if (yyHaveOrdinalMonth) {
+ Tcl_ListObjAppendElement(interp, resultElement,
+ Tcl_NewIntObj(yyMonthOrdinal));
+ Tcl_ListObjAppendElement(interp, resultElement,
+ Tcl_NewIntObj(yyMonth));
}
- return status;
+ Tcl_ListObjAppendElement(interp, result, resultElement);
+
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
Index: generic/tclHash.c
==================================================================
--- generic/tclHash.c
+++ generic/tclHash.c
@@ -1,18 +1,29 @@
/*
- * tclHash.c --
- *
- * Implementation of in-memory hash tables for Tcl and Tcl-based
- * applications.
- *
* 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.
Index: generic/tclHistory.c
==================================================================
--- generic/tclHistory.c
+++ generic/tclHistory.c
@@ -1,18 +1,29 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
/*
Index: generic/tclIO.c
==================================================================
--- generic/tclIO.c
+++ generic/tclIO.c
@@ -1,19 +1,30 @@
/*
- * 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.
- *
* 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
/*
@@ -337,11 +348,11 @@
"channel", /* name for this type */
FreeChannelInternalRep, /* freeIntRepProc */
DupChannelInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define GetIso88591() \
(binaryEncoding ? Tcl_GetEncoding(NULL, "iso8859-1") : binaryEncoding)
@@ -1659,10 +1670,14 @@
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.
*
@@ -4252,11 +4267,11 @@
} else {
result = WriteBytes(chanPtr, src, srcLen);
}
return result;
} else {
- src = TclGetStringFromObj(objPtr, &srcLen);
+ src = Tcl_GetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
static void
@@ -4646,11 +4661,11 @@
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
- (void)TclGetStringFromObj(objPtr, &oldLength);
+ (void)Tcl_GetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
@@ -5934,10 +5949,11 @@
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;
}
/*
@@ -6035,10 +6051,11 @@
*/
if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)
&& !GotFlag(statePtr, CHANNEL_STICKY_EOF)
&& (!GotFlag(statePtr, CHANNEL_NONBLOCKING))) {
+ copied = -1;
goto finish;
}
}
if (copiedNow < 0) {
@@ -6113,10 +6130,13 @@
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;
}
/*
*---------------------------------------------------------------------------
@@ -6247,11 +6267,11 @@
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
if (dstLimit <= 0) {
dstLimit = INT_MAX; /* avoid overflow */
}
- (void) TclGetStringFromObj(objPtr, &numBytes);
+ (void) Tcl_GetStringFromObj(objPtr, &numBytes);
TclAppendUtfToUtf(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
Tcl_Size size;
dst = TclGetStringStorage(objPtr, &size) + numBytes;
@@ -8236,13 +8256,11 @@
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]
-#ifndef TCL_NO_DEPRECATED
|| !strcmp(newValue+1, " {}")
-#endif
))) {
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = newValue[0];
}
} else {
@@ -8626,11 +8644,10 @@
UpdateInterest(
Channel *chanPtr) /* Channel to update. */
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
- ChannelBuffer *bufPtr = statePtr->outQueueHead;
int mask = statePtr->interestMask;
if (chanPtr->typePtr == NULL) {
/* Do not update interest on a closed channel */
return;
@@ -8706,19 +8723,21 @@
}
}
}
if (!statePtr->timer
- && (mask & TCL_WRITABLE)
- && GotFlag(statePtr, CHANNEL_NONBLOCKING)
- && bufPtr
- && !IsBufferEmpty(bufPtr)
- && !IsBufferFull(bufPtr)) {
- TclChannelPreserve((Tcl_Channel)chanPtr);
- statePtr->timerChanPtr = chanPtr;
- statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
- ChannelTimerProc,chanPtr);
+ && (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);
}
@@ -9774,11 +9793,11 @@
* - 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) {
- TclGetStringFromObj(bufObj, &sizePart);
+ Tcl_GetStringFromObj(bufObj, &sizePart);
if (sizePart > 0) {
size = sizePart;
}
}
}
@@ -9843,11 +9862,11 @@
if (moveBytes) {
buffer = csPtr->buffer;
sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size);
} else {
- buffer = TclGetStringFromObj(bufObj, &sizeb);
+ buffer = Tcl_GetStringFromObj(bufObj, &sizeb);
sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb);
}
/*
* [Bug 2895565]. At this point 'size' still contains the number of
Index: generic/tclIO.h
==================================================================
--- generic/tclIO.h
+++ generic/tclIO.h
@@ -1,18 +1,29 @@
/*
- * 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.
- *
* 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
@@ -156,14 +167,10 @@
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. */
-#if TCL_MAJOR_VERSION < 9
- int outEofChar; /* If nonzero, append this to the channel when
- * it is closed if it is open for writing. For Tcl 8.x only */
-#endif
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
Tcl_Size refCount; /* How many interpreters hold references to
* this IO channel? */
Index: generic/tclIOCmd.c
==================================================================
--- generic/tclIOCmd.c
+++ generic/tclIOCmd.c
@@ -1,16 +1,27 @@
/*
- * tclIOCmd.c --
- *
- * Contains the definitions of most of the Tcl commands relating to IO.
- *
* 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"
/*
@@ -305,11 +316,10 @@
TclChannelPreserve(chan);
TclNewObj(linePtr);
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen == TCL_IO_FAILURE) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
- Tcl_DecrRefCount(linePtr);
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
@@ -370,11 +380,12 @@
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, *chanObjPtr;
+ Tcl_Obj *resultPtr, *resultDictPtr, *returnOptsPtr, *chanObjPtr;
+ int res, status;
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
argerror:
@@ -432,18 +443,10 @@
TclNewObj(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
- Tcl_Obj *returnOptsPtr = NULL;
- if (TclChannelGetBlockingMode(chan)) {
- returnOptsPtr = Tcl_NewDictObj();
- Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1),
- resultPtr);
- } else {
- Tcl_DecrRefCount(resultPtr);
- }
/*
* 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.
@@ -452,26 +455,35 @@
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error reading \"%s\": %s",
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
- TclChannelRelease(chan);
- if (returnOptsPtr) {
+ 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 = TclGetStringFromObj(resultPtr, &length);
+ result = Tcl_GetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
@@ -712,11 +724,11 @@
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
- string = TclGetStringFromObj(resultPtr, &len);
+ string = Tcl_GetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, len - 1);
}
return TCL_ERROR;
}
@@ -944,15 +956,10 @@
if (chan == NULL) {
return TCL_ERROR;
}
- /* Bug [0f1ddc0df7] - encoding errors - use replace profile */
- if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) {
- 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).
*/
@@ -997,11 +1004,11 @@
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
- string = TclGetStringFromObj(resultPtr, &length);
+ string = Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
Index: generic/tclIOGT.c
==================================================================
--- generic/tclIOGT.c
+++ generic/tclIOGT.c
@@ -1,18 +1,29 @@
/*
- * tclIOGT.c --
- *
- * Implements a generic transformation exposing the underlying API at the
- * script level. Contributed by Andreas Kupries.
- *
* 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
@@ -377,11 +388,15 @@
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 = TclListObjCopy(NULL, dataPtr->command);
+ Tcl_Obj *command = TclDuplicatePureObj(
+ interp, dataPtr->command, tclListTypePtr);
+ if (!command) {
+ return TCL_ERROR;
+ }
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
/*
Index: generic/tclIORChan.c
==================================================================
--- generic/tclIORChan.c
+++ generic/tclIORChan.c
@@ -1,5 +1,21 @@
+/*
+ * 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
@@ -7,15 +23,10 @@
*
* Parts of this file are based on code contributed by Jean-Claude
* Wippler.
*
* See TIP #219 for the specification of this functionality.
- *
- * 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.
*/
#include "tclInt.h"
#include "tclIO.h"
#include
@@ -2012,11 +2023,11 @@
"elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
Tcl_Size len;
- const char *str = TclGetStringFromObj(resObj, &len);
+ const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
@@ -2254,11 +2265,14 @@
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
- rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
+ 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));
@@ -2392,11 +2406,14 @@
/*
* Insert method into the callback command, after the command prefix,
* before the channel id.
*/
- cmd = TclListObjCopy(NULL, rcPtr->cmd);
+ 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);
/*
@@ -2447,11 +2464,11 @@
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Size cmdLen;
- const char *cmdString = TclGetStringFromObj(cmd, &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));
@@ -3322,11 +3339,11 @@
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
Tcl_Size len;
- const char *str = TclGetStringFromObj(resObj, &len);
+ const char *str = Tcl_GetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
@@ -3434,11 +3451,11 @@
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
- const char *msgStr = TclGetStringFromObj(obj, &len);
+ const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
Index: generic/tclIORTrans.c
==================================================================
--- generic/tclIORTrans.c
+++ generic/tclIORTrans.c
@@ -1,5 +1,21 @@
+/*
+ * 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
@@ -7,15 +23,10 @@
*
* Parts of this file are based on code contributed by Jean-Claude
* Wippler.
*
* See TIP #230 for the specification of this functionality.
- *
- * 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.
*/
#include "tclInt.h"
#include "tclIO.h"
#include
@@ -2000,11 +2011,11 @@
* 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 = TclGetStringFromObj(cmd, &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));
@@ -2768,11 +2779,11 @@
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
Tcl_Size len;
- const char *msgStr = TclGetStringFromObj(obj, &len);
+ const char *msgStr = Tcl_GetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, Tcl_Alloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
Index: generic/tclIOSock.c
==================================================================
--- generic/tclIOSock.c
+++ generic/tclIOSock.c
@@ -1,16 +1,27 @@
/*
- * tclIOSock.c --
- *
- * Common routines used by all socket based channel types.
- *
* 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.
Index: generic/tclIOUtil.c
==================================================================
--- generic/tclIOUtil.c
+++ generic/tclIOUtil.c
@@ -1,20 +1,31 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
#include "tclIO.h"
#ifdef _WIN32
@@ -521,12 +532,12 @@
return 1;
} else {
Tcl_Size len1, len2;
const char *str1, *str2;
- str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
+ 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.
*/
@@ -665,11 +676,11 @@
Tcl_Size len = 0;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
- str = TclGetStringFromObj(cwdObj, &len);
+ str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
@@ -1155,12 +1166,12 @@
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
- mount = TclGetStringFromObj(mElt, &mlen);
- path = TclGetStringFromObj(norm, &len);
+ mount = Tcl_GetStringFromObj(mElt, &mlen);
+ path = Tcl_GetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
*/
@@ -1333,11 +1344,11 @@
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
- path = TclGetStringFromObj(pathPtr, &i);
+ path = Tcl_GetStringFromObj(pathPtr, &i);
if ((i >= 3) && ((path[0] == '/' && path[1] == '/')
|| (path[0] == '\\' && path[1] == '\\'))) {
for (i = 2; ; i++) {
if (path[i] == '\0') {
@@ -1736,10 +1747,15 @@
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);
/*
@@ -1775,11 +1791,11 @@
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
- string = TclGetStringFromObj(objPtr, &length);
+ string = Tcl_GetStringFromObj(objPtr, &length);
/*
* TIP #280: Open a frame for the evaluated script.
*/
@@ -1802,11 +1818,11 @@
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
- const char *pathString = TclGetStringFromObj(pathPtr, &length);
+ 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)",
@@ -1955,11 +1971,11 @@
/*
* Record information about where the error occurred.
*/
Tcl_Size length;
- const char *pathString = TclGetStringFromObj(pathPtr, &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)",
@@ -2805,12 +2821,12 @@
*/
Tcl_Size len1, len2;
const char *str1, *str2;
- str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
- str2 = TclGetStringFromObj(norm, &len2);
+ 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.
@@ -3905,11 +3921,11 @@
* 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 = TclGetStringFromObj(pathPtr, &pathLen);
+ const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
@@ -4012,11 +4028,11 @@
Tcl_Size len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
- strVol = TclGetStringFromObj(vol,&len);
+ strVol = Tcl_GetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, len) == 0) {
type = TCL_PATH_ABSOLUTE;
@@ -4372,12 +4388,12 @@
const char *cwdStr, *normPathStr;
Tcl_Size cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
- normPathStr = TclGetStringFromObj(normPath, &normLen);
- cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen);
+ 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].
Index: generic/tclIndexObj.c
==================================================================
--- generic/tclIndexObj.c
+++ generic/tclIndexObj.c
@@ -1,20 +1,31 @@
/*
- * 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.
- *
* 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:
*/
@@ -34,17 +45,17 @@
/*
* The structure below defines the index Tcl object type by means of functions
* that can be invoked by generic object code.
*/
-const Tcl_ObjType tclIndexType = {
+static const Tcl_ObjType indexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 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
@@ -212,11 +223,11 @@
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
- irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
+ irPtr = TclFetchInternalRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if ((indexRep->tablePtr == tablePtr)
&& (indexRep->offset == offset)
&& (indexRep->index != TCL_INDEX_NONE)) {
@@ -281,19 +292,19 @@
* 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);
+ irPtr = TclFetchInternalRep(objPtr, &indexType);
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);
+ Tcl_StoreInternalRep(objPtr, &indexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
@@ -384,11 +395,11 @@
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1;
+ IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
@@ -416,15 +427,15 @@
Tcl_Obj *dupPtr)
{
Tcl_ObjInternalRep ir;
IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep));
- memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1,
+ memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &indexType)->twoPtrValue.ptr1,
sizeof(IndexRep));
ir.twoPtrValue.ptr1 = dupIndexRep;
- Tcl_StoreInternalRep(dupPtr, &tclIndexType, &ir);
+ Tcl_StoreInternalRep(dupPtr, &indexType, &ir);
}
/*
*----------------------------------------------------------------------
*
@@ -444,11 +455,11 @@
static void
FreeIndex(
Tcl_Obj *objPtr)
{
- Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1);
+ Tcl_Free(TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
@@ -645,14 +656,14 @@
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
resultPtr = Tcl_NewListObj(0, NULL);
- string = TclGetStringFromObj(objv[2], &length);
+ string = Tcl_GetStringFromObj(objv[2], &length);
for (t = 0; t < tableObjc; t++) {
- elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
+ elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
/*
* A prefix cannot match if it is longest.
*/
@@ -702,17 +713,17 @@
result = TclListObjGetElements(interp, objv[1], &tableObjc, &tableObjv);
if (result != TCL_OK) {
return result;
}
- string = TclGetStringFromObj(objv[2], &length);
+ string = Tcl_GetStringFromObj(objv[2], &length);
resultString = NULL;
resultLength = 0;
for (t = 0; t < tableObjc; t++) {
- elemString = TclGetStringFromObj(tableObjv[t], &elemLength);
+ elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength);
/*
* First check if the prefix string matches the element. A prefix
* cannot match if it is longest.
*/
@@ -864,17 +875,17 @@
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjInternalRep *irPtr;
- if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
+ if ((irPtr = TclFetchInternalRep(origObjv[i], &indexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
- elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
+ elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
@@ -911,20 +922,20 @@
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
const Tcl_ObjInternalRep *irPtr;
- if ((irPtr = TclFetchInternalRep(objv[i], &tclIndexType))) {
+ if ((irPtr = TclFetchInternalRep(objv[i], &indexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *)NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
- elementStr = TclGetStringFromObj(objv[i], &elemLen);
+ elementStr = Tcl_GetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
@@ -1047,11 +1058,11 @@
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
- str = TclGetStringFromObj(curArg, &length);
+ str = Tcl_GetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
c = 0;
}
@@ -1363,11 +1374,11 @@
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
- if (!TclHasInternalRep(value, &tclIndexType)
+ if (!TclHasInternalRep(value, &indexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
if (Tcl_GetIndexFromObjStruct(NULL, value, returnCodes,
sizeof(char *), NULL, TCL_EXACT, codePtr) == TCL_OK) {
Index: generic/tclInt.decls
==================================================================
--- generic/tclInt.decls
+++ generic/tclInt.decls
@@ -1,18 +1,26 @@
+# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright © 2001 Kevin B. Kenny. All rights reserved.
+# Copyright © 2007 Daniel A. Steffen
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
#
-# Copyright © 1998-1999 Scriptics Corporation.
-# Copyright © 2001 Kevin B. Kenny. All rights reserved.
-# Copyright © 2007 Daniel A. Steffen
-#
-# 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 unsupported generic interfaces.
@@ -35,10 +43,15 @@
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)
@@ -283,14 +296,37 @@
}
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,
@@ -302,10 +338,18 @@
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 {
@@ -350,10 +394,18 @@
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 {
@@ -386,10 +438,17 @@
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 {
@@ -418,10 +477,26 @@
}
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]
@@ -540,10 +615,14 @@
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)
}
@@ -653,10 +732,14 @@
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,
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -1,23 +1,35 @@
/*
- * tclInt.h --
- *
- * Declarations of things used internally by the Tcl interpreter.
- *
* 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
* 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.
@@ -44,14 +56,17 @@
# 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
@@ -200,10 +215,107 @@
* 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.
*----------------------------------------------------------------
@@ -220,13 +332,11 @@
*/
typedef struct TclVarHashTable {
Tcl_HashTable table;
struct Namespace *nsPtr;
-#if TCL_MAJOR_VERSION > 8
struct Var *arrayPtr;
-#endif /* TCL_MAJOR_VERSION > 8 */
} TclVarHashTable;
/*
* This is for itcl - it likes to search our varTables directly :(
*/
@@ -272,15 +382,11 @@
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
-#if TCL_MAJOR_VERSION > 8
size_t nsId; /* Unique id for the namespace. */
-#else
- unsigned long nsId;
-#endif
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
@@ -422,17 +528,14 @@
*
* 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.
- * TCL_FIND_IF_NOT_SIMPLE - Retrieve last namespace even if the rest of
- * name is not simple name (contains ::).
*/
#define TCL_CREATE_NS_IF_UNKNOWN 0x800
#define TCL_FIND_ONLY_NS 0x1000
-#define TCL_FIND_IF_NOT_SIMPLE 0x2000
/*
* 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,
@@ -975,13 +1078,10 @@
* 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. */
-#if TCL_MAJOR_VERSION < 9
- int flags;
-#endif
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
@@ -988,16 +1088,14 @@
* 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. */
-#if TCL_MAJOR_VERSION > 8
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. */
-#endif
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! */
@@ -1051,15 +1149,11 @@
*/
typedef struct Trace {
Tcl_Size level; /* Only trace commands at nesting level less
* than or equal to this. */
-#if TCL_MAJOR_VERSION > 8
Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */
-#else
- Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
-#endif
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;
@@ -1099,107 +1193,10 @@
*/
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
-#if TCL_MAJOR_VERSION > 8
-#define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \
- && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \
- || (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \
- ((objPtr)->typePtr)->proc : NULL)
-
-MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);
-
-/*
- * Abstract List
- *
- * This structure provides the functions used in List operations to emulate a
- * List for AbstractList types.
- */
-
-static inline Tcl_Size
-TclObjTypeLength(
- Tcl_Obj *objPtr)
-{
- Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc);
- return proc(objPtr);
-}
-static inline int
-TclObjTypeIndex(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Size index,
- Tcl_Obj **elemObjPtr)
-{
- Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc);
- return proc(interp, objPtr, index, elemObjPtr);
-}
-static inline int
-TclObjTypeSlice(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Size fromIdx,
- Tcl_Size toIdx,
- Tcl_Obj **newObjPtr)
-{
- Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc);
- return proc(interp, objPtr, fromIdx, toIdx, newObjPtr);
-}
-static inline int
-TclObjTypeReverse(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Obj **newObjPtr)
-{
- Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc);
- return proc(interp, objPtr, newObjPtr);
-}
-static inline int
-TclObjTypeGetElements(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Size *objCPtr,
- Tcl_Obj ***objVPtr)
-{
- Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc);
- return proc(interp, objPtr, objCPtr, objVPtr);
-}
-static inline Tcl_Obj*
-TclObjTypeSetElement(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Size indexCount,
- Tcl_Obj *const indexArray[],
- Tcl_Obj *valueObj)
-{
- Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc);
- return proc(interp, objPtr, indexCount, indexArray, valueObj);
-}
-static inline int
-TclObjTypeReplace(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- Tcl_Size first,
- Tcl_Size numToDelete,
- Tcl_Size numToInsert,
- Tcl_Obj *const insertObjs[])
-{
- Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc);
- return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs);
-}
-static inline int
-TclObjTypeInOperator(
- Tcl_Interp *interp,
- Tcl_Obj *valueObj,
- Tcl_Obj *listObj,
- int *boolResult)
-{
- Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc);
- return proc(interp, valueObj, listObj, boolResult);
-}
-#endif /* TCL_MAJOR_VERSION > 8 */
-
/*
* 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.
@@ -1974,22 +1971,11 @@
* 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. */
-#if TCL_MAJOR_VERSION > 8
- void (*optimizer)(void *envPtr);
-#else
- union {
- void (*optimizer)(void *envPtr);
- Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
- * unused space in interp was repurposed for
- * pluggable bytecode optimizers. The core
- * contains one optimizer, which can be
- * selectively overridden by extensions. */
- } extra;
-#endif
+ void (*optimizer)(void *envPtr);
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
@@ -2014,16 +2000,10 @@
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
-#if TCL_MAJOR_VERSION < 9
- char *appendResultDontUse;
- int appendAvlDontUse;
- int appendUsedDontUse;
-#endif
-
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
@@ -2042,13 +2022,10 @@
* 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. */
-#if TCL_MAJOR_VERSION < 9
- int unused1; /* No longer used (was termOffset) */
-#endif
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. */
@@ -2081,13 +2058,10 @@
* 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. */
-#if TCL_MAJOR_VERSION < 9
- char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
-#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
@@ -2110,11 +2084,11 @@
* 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 ::errorInfo variable. */
+ Tcl_Obj *ecVar; /* cached ref to ::errorCode variable. */
int returnLevel; /* [return -level] parameter. */
/*
* Resource limiting framework support (TIP#143).
*/
@@ -2532,10 +2506,11 @@
*/
#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.
@@ -2708,30 +2683,30 @@
* 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_), &tclListType)) \
- ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
- TCL_OK) \
- : Tcl_ListObjGetElements( \
- (interp_), (listObj_), (objcPtr_), (objvPtr_)))
+#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_), &tclListType)) \
- ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
- : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
-
-#define TclListObjIsCanonical(listObj_) \
- ((TclHasInternalRep((listObj_), &tclListType)) \
- ? ListObjIsCanonical((listObj_)) \
+#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.
@@ -2746,64 +2721,56 @@
* and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
-#if TCL_MAJOR_VERSION > 8
-#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType) \
- || TclHasInternalRep((objPtr), &tclBooleanType)) \
- ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
-#else
-#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType)) \
- ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
- : (TclHasInternalRep((objPtr), &tclBooleanType)) \
- ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
-#endif
-
-#ifdef TCL_WIDE_INT_IS_LONG
-#define TclGetLongFromObj(interp, objPtr, longPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType)) \
- ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
- : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
-#else
-#define TclGetLongFromObj(interp, objPtr, longPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType) \
- && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
- && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
- ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
- : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
-#endif
-
-#define TclGetIntFromObj(interp, objPtr, intPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType) \
- && (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), &tclIntType)) \
- && ((objPtr)->internalRep.wideValue >= 0) \
- && ((objPtr)->internalRep.wideValue <= endValue)) \
- ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
- : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
+#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
+ ((TclHasInternalRep((objPtr), tclIntType)) \
+ || TclHasInternalRep((objPtr), tclBooleanType) \
+ ? (*(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), tclIntType)) \
+ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+#else
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ ((TclHasInternalRep((objPtr), tclIntType) \
+ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
+ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+#endif
+
+#define TclGetIntFromObj(interp, objPtr, intPtr) \
+ ((TclHasInternalRep((objPtr), tclIntType) \
+ && (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), tclIntType)) \
+ && ((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), &tclIntType)) \
- ? (*(wideIntPtr) = ((objPtr)->internalRep.wideValue), TCL_OK) \
- : Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ ((TclHasInternalRep((objPtr), tclIntType)) \
+ ? (*(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
@@ -3103,18 +3070,17 @@
/*
* Variables denoting the Tcl object types defined in the core.
*/
-MODULE_SCOPE const Tcl_ObjType tclBignumType;
-MODULE_SCOPE const Tcl_ObjType tclBooleanType;
+MODULE_SCOPE const Tcl_ObjType *tclBignumType;
+MODULE_SCOPE const Tcl_ObjType *tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
-MODULE_SCOPE const Tcl_ObjType tclDoubleType;
-MODULE_SCOPE const Tcl_ObjType tclIntType;
-MODULE_SCOPE const Tcl_ObjType tclIndexType;
-MODULE_SCOPE const Tcl_ObjType tclListType;
-MODULE_SCOPE const Tcl_ObjType tclDictType;
+MODULE_SCOPE const Tcl_ObjType *tclDoubleType;
+MODULE_SCOPE const Tcl_ObjType *tclIntType;
+MODULE_SCOPE Tcl_ObjType * tclListTypePtr;
+MODULE_SCOPE Tcl_ObjType * tclDictTypePtr;
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;
@@ -3249,11 +3215,10 @@
*----------------------------------------------------------------
* Procedures shared among Tcl modules but not used by the outside world:
*----------------------------------------------------------------
*/
-#if TCL_MAJOR_VERSION > 8
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,
@@ -3270,10 +3235,11 @@
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,
@@ -3283,11 +3249,11 @@
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_Obj *objPtr);
+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 Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
@@ -3308,16 +3274,17 @@
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 Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr);
+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 Tcl_Obj * TclDictObjSmartRef(Tcl_Interp *interp, Tcl_Obj *);
/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
Tcl_Size numBytes, int flags, Tcl_Size line,
Tcl_Size *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
@@ -3395,10 +3362,12 @@
MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp,
const char *targetName,
const char *packageName);
MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
Tcl_WideInt *);
+MODULE_SCOPE int TclIndexIsFromEnd(Tcl_Size encoded);
+MODULE_SCOPE Tcl_Size TclIndexLast (Tcl_Size N);
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;
@@ -3433,24 +3402,27 @@
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 Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
+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 Tcl_Obj * TclListObjRange(Tcl_Interp *interp, Tcl_Obj *listPtr,
- Tcl_Size fromIdx, Tcl_Size toIdx);
+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 Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
- Tcl_Size indexCount, Tcl_Obj *const indexArray[],
- 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,
@@ -3458,10 +3430,14 @@
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 * 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[],
@@ -3481,16 +3457,17 @@
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 int TclNewArithSeriesObj(Tcl_Interp *interp,
- Tcl_Obj **arithSeriesPtr,
- int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj,
- Tcl_Obj *stepObj, Tcl_Obj *lenObj);
+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);
@@ -3540,10 +3517,11 @@
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);
@@ -3584,10 +3562,12 @@
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,
@@ -3613,10 +3593,11 @@
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);
@@ -4104,12 +4085,10 @@
* Error message utility functions
*/
MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp,
Tcl_Size count);
-#endif /* TCL_MAJOR_VERSION > 8 */
-
/* Constants used in index value encoding routines. */
#define TCL_INDEX_END ((Tcl_Size)-2)
#define TCL_INDEX_START ((Tcl_Size)0)
/*
@@ -4387,16 +4366,17 @@
*/
#define TclInitEmptyStringRep(objPtr) \
((objPtr)->length = (((objPtr)->bytes = &tclEmptyString), 0))
-#define TclInitStringRep(objPtr, bytePtr, len) \
+#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)); \
+ memcpy((objPtr)->bytes, (bytePtr) \
+ ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
#define TclAttemptInitStringRep(objPtr, bytePtr, len) \
@@ -4403,11 +4383,12 @@
((((len) == 0) ? ( \
TclInitEmptyStringRep(objPtr) \
) : ( \
(objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \
(objPtr)->length = ((objPtr)->bytes) ? \
- (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \
+ (memcpy((objPtr)->bytes, (bytePtr) \
+ ? (bytePtr) : &tclEmptyString, (len)), \
(objPtr)->bytes[len] = '\0', (len)) : (-1) \
)), (objPtr)->bytes)
/*
*----------------------------------------------------------------
@@ -4422,11 +4403,11 @@
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
-#define TclGetStringFromObj(objPtr, lenPtr) \
+#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
: (Tcl_GetStringFromObj)((objPtr), (lenPtr)))
/*
@@ -4638,13 +4619,13 @@
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
#define TclIsPureDict(objPtr) \
- (((objPtr)->bytes == NULL) && TclHasInternalRep((objPtr), &tclDictType))
+ (((objPtr)->bytes==NULL) && TclHasInternalRep((objPtr), tclDictTypePtr))
#define TclHasInternalRep(objPtr, type) \
- ((objPtr)->typePtr == (type))
+ ((objPtr)->typePtr == (void *)(type))
#define TclFetchInternalRep(objPtr, type) \
(TclHasInternalRep((objPtr), (type)) ? &(objPtr)->internalRep : NULL)
/*
*----------------------------------------------------------------
@@ -4686,12 +4667,13 @@
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:
*
@@ -4717,19 +4699,19 @@
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
+ Tcl_StoreInternalRep(objPtr, tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
do { \
Tcl_ObjInternalRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
- Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
+ Tcl_StoreInternalRep(objPtr, tclDoubleType, &ir); \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
@@ -4736,11 +4718,11 @@
* 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 TclNewStringObj(Tcl_Obj *objPtr, const char *s, * Tcl_Size len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
@@ -4750,11 +4732,11 @@
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclIntType; \
+ (objPtr)->typePtr = tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewUIntObj(objPtr, uw) \
do { \
@@ -4769,26 +4751,26 @@
Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
} \
TclSetBignumInternalRep((objPtr), &bignumValue_); \
} else { \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
- (objPtr)->typePtr = &tclIntType; \
+ (objPtr)->typePtr = tclIntType; \
} \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewIndexObj(objPtr, w) \
- TclNewIntObj(objPtr, w)
+#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 = &tclDoubleType; \
+ (objPtr)->typePtr = tclDoubleType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewStringObj(objPtr, s, len) \
do { \
@@ -4866,15 +4848,15 @@
*----------------------------------------------------------------
* 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); \
- } \
+#define TclCleanupCommandMacro(cmdPtr) \
+ do { \
+ if ((cmdPtr)->refCount-- <= 1) { \
+ Tcl_Free(cmdPtr); \
+ } \
} while (0)
/*
* inside this routine crement refCount first incase cmdPtr is replacing itself
*/
@@ -5045,11 +5027,11 @@
#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)))
+ ((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))
Index: generic/tclIntDecls.h
==================================================================
--- generic/tclIntDecls.h
+++ generic/tclIntDecls.h
@@ -1,17 +1,28 @@
+/*
+ * 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.
- *
- * 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 _TCLINTDECLS
#define _TCLINTDECLS
@@ -1267,24 +1278,13 @@
#undef Tcl_StaticLibrary
#define Tcl_StaticLibrary \
(tclIntStubsPtr->tclStaticLibrary)
#endif /* defined(USE_TCL_STUBS) */
-#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS)
-#undef TclpGetClicks
-#define TclpGetClicks() \
- ((unsigned long)tclIntStubsPtr->tclpGetClicks())
-#undef TclpGetSeconds
-#define TclpGetSeconds() \
- ((unsigned long)tclIntStubsPtr->tclpGetSeconds())
-#undef TclGetObjInterpProc2
-#define TclGetObjInterpProc2 TclGetObjInterpProc
-#endif
-
#undef TclUnusedStubEntry
#define TclObjInterpProc TclGetObjInterpProc()
#define TclObjInterpProc2 TclGetObjInterpProc2()
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLINTDECLS */
Index: generic/tclIntPlatDecls.h
==================================================================
--- generic/tclIntPlatDecls.h
+++ generic/tclIntPlatDecls.h
@@ -1,15 +1,26 @@
+/*
+ * 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.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * All rights reserved.
*/
#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS
@@ -28,496 +39,10 @@
* 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.
*/
-#if TCL_MAJOR_VERSION < 9
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/*
- * Exported function declarations:
- */
-
-#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
-/* 0 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
-/* 1 */
-EXTERN int TclpCloseFile(TclFile file);
-/* 2 */
-EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
- TclFile writeFile, TclFile errorFile,
- int numPids, Tcl_Pid *pidPtr);
-/* 3 */
-EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-/* 4 */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- const char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr);
-/* Slot 5 is reserved */
-/* 6 */
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-/* 7 */
-EXTERN TclFile TclpOpenFile(const char *fname, int mode);
-/* 8 */
-EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
-/* 9 */
-EXTERN TclFile TclpCreateTempFile(const char *contents);
-/* 10 */
-EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir);
-/* Slot 11 is reserved */
-/* Slot 12 is reserved */
-/* Slot 13 is reserved */
-/* 14 */
-EXTERN int TclUnixCopyFile(const char *src, const char *dst,
- const Tcl_StatBuf *statBufPtr,
- int dontCopyAtts);
-/* 15 */
-EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr);
-/* 16 */
-EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj *attributePtr);
-/* 17 */
-EXTERN int TclMacOSXCopyFileAttributes(const char *src,
- const char *dst,
- const Tcl_StatBuf *statBufPtr);
-/* 18 */
-EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
- const char *pathName, const char *fileName,
- Tcl_StatBuf *statBufPtr,
- Tcl_GlobTypeData *types);
-/* 19 */
-EXTERN void TclMacOSXNotifierAddRunLoopMode(
- const void *runLoopMode);
-/* Slot 20 is reserved */
-/* Slot 21 is reserved */
-/* Slot 22 is reserved */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
-/* 29 */
-EXTERN int TclWinCPUID(int index, int *regs);
-/* 30 */
-EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
- Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
- Tcl_Obj *resultingNameObj);
-#endif /* UNIX */
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
-/* Slot 0 is reserved */
-/* Slot 1 is reserved */
-/* Slot 2 is reserved */
-/* Slot 3 is reserved */
-/* 4 */
-EXTERN void * TclWinGetTclInstance(void);
-/* 5 */
-EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
-/* Slot 6 is reserved */
-/* Slot 7 is reserved */
-/* 8 */
-EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid);
-/* Slot 9 is reserved */
-/* Slot 10 is reserved */
-/* 11 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
-/* 12 */
-EXTERN int TclpCloseFile(TclFile file);
-/* 13 */
-EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
- TclFile writeFile, TclFile errorFile,
- int numPids, Tcl_Pid *pidPtr);
-/* 14 */
-EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-/* 15 */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- const char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr);
-/* 16 */
-EXTERN int TclpIsAtty(int fd);
-/* 17 */
-EXTERN int TclUnixCopyFile(const char *src, const char *dst,
- const Tcl_StatBuf *statBufPtr,
- int dontCopyAtts);
-/* 18 */
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-/* 19 */
-EXTERN TclFile TclpOpenFile(const char *fname, int mode);
-/* 20 */
-EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id);
-/* Slot 21 is reserved */
-/* 22 */
-EXTERN TclFile TclpCreateTempFile(const char *contents);
-/* Slot 23 is reserved */
-/* 24 */
-EXTERN char * TclWinNoBackslash(char *path);
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* 27 */
-EXTERN void TclWinFlushDirtyChannels(void);
-/* Slot 28 is reserved */
-/* 29 */
-EXTERN int TclWinCPUID(int index, int *regs);
-/* 30 */
-EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
- Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
- Tcl_Obj *resultingNameObj);
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
-/* 0 */
-EXTERN void TclGetAndDetachPids(Tcl_Interp *interp,
- Tcl_Channel chan);
-/* 1 */
-EXTERN int TclpCloseFile(TclFile file);
-/* 2 */
-EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
- TclFile writeFile, TclFile errorFile,
- int numPids, Tcl_Pid *pidPtr);
-/* 3 */
-EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe);
-/* 4 */
-EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc,
- const char **argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid *pidPtr);
-/* Slot 5 is reserved */
-/* 6 */
-EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
-/* 7 */
-EXTERN TclFile TclpOpenFile(const char *fname, int mode);
-/* 8 */
-EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
-/* 9 */
-EXTERN TclFile TclpCreateTempFile(const char *contents);
-/* 10 */
-EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir);
-/* Slot 13 is reserved */
-/* 14 */
-EXTERN int TclUnixCopyFile(const char *src, const char *dst,
- const Tcl_StatBuf *statBufPtr,
- int dontCopyAtts);
-/* 15 */
-EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj **attributePtrPtr);
-/* 16 */
-EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp,
- int objIndex, Tcl_Obj *fileName,
- Tcl_Obj *attributePtr);
-/* 17 */
-EXTERN int TclMacOSXCopyFileAttributes(const char *src,
- const char *dst,
- const Tcl_StatBuf *statBufPtr);
-/* 18 */
-EXTERN int TclMacOSXMatchType(Tcl_Interp *interp,
- const char *pathName, const char *fileName,
- Tcl_StatBuf *statBufPtr,
- Tcl_GlobTypeData *types);
-/* 19 */
-EXTERN void TclMacOSXNotifierAddRunLoopMode(
- const void *runLoopMode);
-/* Slot 20 is reserved */
-/* Slot 21 is reserved */
-/* Slot 22 is reserved */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
-/* 29 */
-EXTERN int TclWinCPUID(int index, int *regs);
-/* 30 */
-EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
- Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
- Tcl_Obj *resultingNameObj);
-#endif /* MACOSX */
-
-typedef struct TclIntPlatStubs {
- int magic;
- void *hooks;
-
-#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
- int (*tclpCloseFile) (TclFile file); /* 1 */
- Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
- int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
- int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
- TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
- int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
- Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
- void (*reserved11)(void);
- void (*reserved12)(void);
- void (*reserved13)(void);
- int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
- int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
- int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
- int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
- int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
- void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
- void (*reserved20)(void);
- void (*reserved21)(void);
- TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
- void (*reserved23)(void);
- void (*reserved24)(void);
- void (*reserved25)(void);
- void (*reserved26)(void);
- void (*reserved27)(void);
- void (*reserved28)(void);
- int (*tclWinCPUID) (int index, int *regs); /* 29 */
- int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
-#endif /* UNIX */
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
- void (*reserved0)(void);
- void (*reserved1)(void);
- void (*reserved2)(void);
- void (*reserved3)(void);
- void * (*tclWinGetTclInstance) (void); /* 4 */
- int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
- void (*reserved6)(void);
- void (*reserved7)(void);
- Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */
- void (*reserved9)(void);
- void *(*tclpReaddir) (void *dir); /* 10 */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
- int (*tclpCloseFile) (TclFile file); /* 12 */
- Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
- int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
- int (*tclpIsAtty) (int fd); /* 16 */
- int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
- TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
- TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
- void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */
- void (*reserved21)(void);
- TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
- void (*reserved23)(void);
- char * (*tclWinNoBackslash) (char *path); /* 24 */
- void (*reserved25)(void);
- void (*reserved26)(void);
- void (*tclWinFlushDirtyChannels) (void); /* 27 */
- void (*reserved28)(void);
- int (*tclWinCPUID) (int index, int *regs); /* 29 */
- int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
- void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
- int (*tclpCloseFile) (TclFile file); /* 1 */
- Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
- int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
- int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
- int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
- TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
- TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
- int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
- TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
- Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
- void (*reserved11)(void);
- void (*reserved12)(void);
- void (*reserved13)(void);
- int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
- int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
- int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
- int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
- int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
- void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
- void (*reserved20)(void);
- void (*reserved21)(void);
- TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
- void (*reserved23)(void);
- void (*reserved24)(void);
- void (*reserved25)(void);
- void (*reserved26)(void);
- void (*reserved27)(void);
- void (*reserved28)(void);
- int (*tclWinCPUID) (int index, int *regs); /* 29 */
- int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
-#endif /* MACOSX */
-} TclIntPlatStubs;
-
-extern const TclIntPlatStubs *tclIntPlatStubsPtr;
-
-#ifdef __cplusplus
-}
-#endif
-
-#if defined(USE_TCL_STUBS)
-
-/*
- * Inline function declarations:
- */
-
-#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
-#define TclpCreateCommandChannel \
- (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
-#define TclpCreatePipe \
- (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclpCreateProcess \
- (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
-/* Slot 5 is reserved */
-#define TclpMakeFile \
- (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#define TclpOpenFile \
- (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
-#define TclUnixWaitForFile \
- (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#define TclpCreateTempFile \
- (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
-#define TclpReaddir \
- (tclIntPlatStubsPtr->tclpReaddir) /* 10 */
-/* Slot 11 is reserved */
-/* Slot 12 is reserved */
-/* Slot 13 is reserved */
-#define TclUnixCopyFile \
- (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-#define TclMacOSXGetFileAttribute \
- (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
-#define TclMacOSXSetFileAttribute \
- (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
-#define TclMacOSXCopyFileAttributes \
- (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
-#define TclMacOSXMatchType \
- (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
-#define TclMacOSXNotifierAddRunLoopMode \
- (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-/* Slot 20 is reserved */
-/* Slot 21 is reserved */
-/* Slot 22 is reserved */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
-#define TclWinCPUID \
- (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#define TclUnixOpenTemporaryFile \
- (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
-#endif /* UNIX */
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
-/* Slot 0 is reserved */
-/* Slot 1 is reserved */
-/* Slot 2 is reserved */
-/* Slot 3 is reserved */
-#define TclWinGetTclInstance \
- (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
-#define TclUnixWaitForFile \
- (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */
-/* Slot 6 is reserved */
-/* Slot 7 is reserved */
-#define TclpGetPid \
- (tclIntPlatStubsPtr->tclpGetPid) /* 8 */
-/* Slot 9 is reserved */
-/* Slot 10 is reserved */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
-#define TclpCreateCommandChannel \
- (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
-#define TclpCreatePipe \
- (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
-#define TclpCreateProcess \
- (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
-#define TclpIsAtty \
- (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */
-#define TclUnixCopyFile \
- (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */
-#define TclpMakeFile \
- (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
-#define TclpOpenFile \
- (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
-#define TclWinAddProcess \
- (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
-/* Slot 21 is reserved */
-#define TclpCreateTempFile \
- (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-/* Slot 23 is reserved */
-#define TclWinNoBackslash \
- (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-#define TclWinFlushDirtyChannels \
- (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
-/* Slot 28 is reserved */
-#define TclWinCPUID \
- (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#define TclUnixOpenTemporaryFile \
- (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
-#define TclGetAndDetachPids \
- (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
-#define TclpCloseFile \
- (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
-#define TclpCreateCommandChannel \
- (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
-#define TclpCreatePipe \
- (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
-#define TclpCreateProcess \
- (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
-/* Slot 5 is reserved */
-#define TclpMakeFile \
- (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
-#define TclpOpenFile \
- (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
-#define TclUnixWaitForFile \
- (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
-#define TclpCreateTempFile \
- (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
-#define TclpReaddir \
- (tclIntPlatStubsPtr->tclpReaddir) /* 10 */
-/* Slot 11 is reserved */
-/* Slot 12 is reserved */
-/* Slot 13 is reserved */
-#define TclUnixCopyFile \
- (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */
-#define TclMacOSXGetFileAttribute \
- (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */
-#define TclMacOSXSetFileAttribute \
- (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */
-#define TclMacOSXCopyFileAttributes \
- (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */
-#define TclMacOSXMatchType \
- (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */
-#define TclMacOSXNotifierAddRunLoopMode \
- (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */
-/* Slot 20 is reserved */
-/* Slot 21 is reserved */
-/* Slot 22 is reserved */
-/* Slot 23 is reserved */
-/* Slot 24 is reserved */
-/* Slot 25 is reserved */
-/* Slot 26 is reserved */
-/* Slot 27 is reserved */
-/* Slot 28 is reserved */
-#define TclWinCPUID \
- (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */
-#define TclUnixOpenTemporaryFile \
- (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
-#endif /* MACOSX */
-
-#endif /* defined(USE_TCL_STUBS) */
-
-#else /* TCL_MAJOR_VERSION > 8 */
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
extern "C" {
#endif
@@ -686,15 +211,23 @@
(tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
-#endif /* TCL_MAJOR_VERSION */
#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 */
@@ -717,23 +250,18 @@
#undef TclMacOSXMatchType /* 18 */
#undef TclMacOSXNotifierAddRunLoopMode /* 19 */
#endif
#if defined(_WIN32)
-# if !defined(TCL_NO_DEPRECATED)
-# define TclWinConvertError Tcl_WinConvertError
-# define TclWinConvertWSAError Tcl_WinConvertError
-# define TclWinNToHS ntohs
-# define TclpInetNtoa inet_ntoa
-# define TclWinGetServByName getservbyname
-# define TclWinGetSockOpt getsockopt
-# define TclWinSetSockOpt setsockopt
-# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
-# define TclWinResetInterfaces() /* nop */
-# define TclWinSetInterfaces(dummy) /* nop */
-# endif /* TCL_NO_DEPRECATED */
+# undef TclWinNToHS
+# undef TclWinGetServByName
+# undef TclWinGetSockOpt
+# undef TclWinSetSockOpt
+# undef TclWinGetPlatformId
+# undef TclWinResetInterfaces
+# undef TclWinSetInterfaces
#else
# undef TclpGetPid
-# define TclpGetPid(pid) ((Tcl_Size)(pid))
+# define TclpGetPid(pid) ((size_t)(pid))
#endif
#endif /* _TCLINTPLATDECLS */
Index: generic/tclInterp.c
==================================================================
--- generic/tclInterp.c
+++ generic/tclInterp.c
@@ -1,18 +1,29 @@
/*
- * tclInterp.c --
- *
- * This file implements the "interp" command which allows creation and
- * manipulation of Tcl interpreters from within Tcl scripts.
- *
* 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
@@ -620,13 +631,11 @@
"children", "create", "debug", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit",
"share",
-#ifndef TCL_NO_DEPRECATED
"slaves",
-#endif
"target", "transfer", NULL
};
static const char *const optionsNoSlaves[] = {
"alias", "aliases", "bgerror", "cancel",
"children", "create", "debug", "delete",
@@ -640,13 +649,11 @@
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,
-#ifndef TCL_NO_DEPRECATED
OPT_SLAVES,
-#endif
OPT_TARGET, OPT_TRANSFER
} index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
@@ -1031,13 +1038,11 @@
childInterp = GetInterp(interp, objv[2]);
if (childInterp == NULL) {
return TCL_ERROR;
}
return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3);
-#ifndef TCL_NO_DEPRECATED
case OPT_SLAVES:
-#endif
case OPT_CHILDREN: {
InterpInfo *iiPtr;
Tcl_Obj *resultPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hashSearch;
@@ -4532,11 +4537,11 @@
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) TclGetStringFromObj(scriptObj, &scriptLen);
+ (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;
@@ -4549,11 +4554,11 @@
return TCL_ERROR;
}
break;
case OPT_VAL:
limitObj = objv[i+1];
- (void) TclGetStringFromObj(objv[i+1], &limitLen);
+ (void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
if (limitLen == 0) {
break;
}
if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
return TCL_ERROR;
@@ -4740,11 +4745,11 @@
return TCL_ERROR;
}
switch (index) {
case OPT_CMD:
scriptObj = objv[i+1];
- (void) TclGetStringFromObj(objv[i+1], &scriptLen);
+ (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;
@@ -4757,11 +4762,11 @@
return TCL_ERROR;
}
break;
case OPT_MILLI:
milliObj = objv[i+1];
- (void) TclGetStringFromObj(objv[i+1], &milliLen);
+ (void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
if (milliLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
@@ -4775,11 +4780,11 @@
}
limitMoment.usec = tmp*1000;
break;
case OPT_SEC:
secObj = objv[i+1];
- (void) TclGetStringFromObj(objv[i+1], &secLen);
+ (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
if (secLen == 0) {
break;
}
if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
return TCL_ERROR;
Index: generic/tclLink.c
==================================================================
--- generic/tclLink.c
+++ generic/tclLink.c
@@ -1,22 +1,24 @@
/*
- * 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.
- *
* 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
/*
@@ -113,11 +115,11 @@
"invalidReal", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 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
@@ -521,11 +523,11 @@
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
- Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, tclDoubleType);
if (irPtr != NULL) {
*dblPtr = irPtr->doubleValue;
return 0;
}
@@ -568,11 +570,11 @@
{
const char *str;
const char *endPtr;
Tcl_Size length;
- str = TclGetStringFromObj(objPtr, &length);
+ str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
@@ -613,11 +615,11 @@
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
Tcl_Size length;
- const char *str = TclGetStringFromObj(objPtr, &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;
@@ -822,19 +824,19 @@
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
- value = TclGetStringFromObj(valueObj, &valueLength);
+ 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 *) TclGetStringFromObj(valueObj, &valueLength);
+ 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) {
Index: generic/tclListObj.c
==================================================================
--- generic/tclListObj.c
+++ generic/tclListObj.c
@@ -1,14 +1,27 @@
+/*
+ * 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.
*
- * Copyright © 2022 Ashok P. Nadkarni. All rights reserved.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include
#include "tclInt.h"
#include "tclTomMath.h"
@@ -66,11 +79,11 @@
#endif
/* Checks for when caller should have already converted to internal list type */
#define LIST_ASSERT_TYPE(listObj_) \
- LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType))
+ 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
@@ -128,46 +141,101 @@
ListRep *);
static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);
static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr);
static void ListRepRange(ListRep *srcRepPtr,
- Tcl_Size rangeStart,
- Tcl_Size rangeEnd,
+ 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);
-static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+int TclSetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfList(Tcl_Obj *listPtr);
-static Tcl_Size ListLength(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.
*/
-const Tcl_ObjType tclListType = {
- "list", /* name */
+static ObjectType tclListObjectType = {
+ "list",
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
- SetListFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V1(ListLength)
+ 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 ListRepIncrRefs(repPtr_) \
- do { \
- (repPtr_)->storePtr->refCount++; \
- if ((repPtr_)->spanPtr) { \
- (repPtr_)->spanPtr->refCount++; \
- } \
+
+#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 \
@@ -201,11 +269,11 @@
*/
#define ListObjStompRep(objPtr_, repPtr_) \
do { \
(objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
(objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
- (objPtr_)->typePtr = &tclListType; \
+ (objPtr_)->typePtr = tclListTypePtr; \
} while (0)
#define ListObjOverwriteRep(objPtr_, repPtr_) \
do { \
ListRepIncrRefs(repPtr_); \
@@ -1246,25 +1314,25 @@
*/
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listObj, /* List object for which an element array is
+ Tcl_Obj *listPtr, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
- if (!TclHasInternalRep(listObj, &tclListType)) {
+ if (!TclHasInternalRep(listPtr, tclListTypePtr)) {
int result;
- result = SetListFromAny(interp, listObj);
+ 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(listObj, repPtr);
+ ListObjGetRep(listPtr, repPtr);
LISTREP_CHECK(repPtr);
return TCL_OK;
}
/*
@@ -1314,54 +1382,10 @@
TclFreeInternalRep(objPtr);
TclInvalidateStringRep(objPtr);
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclListObjCopy --
- *
- * Makes a "pure list" copy of a list value. This provides for the C
- * level a counterpart of the [lrange $list 0 end] command, while using
- * internals details to be as efficient as possible.
- *
- * Results:
- * Normally returns a pointer to a new Tcl_Obj, that contains the same
- * list value as *listPtr does. The returned Tcl_Obj has a refCount of
- * zero. If *listPtr does not hold a list, NULL is returned, and if
- * interp is non-NULL, an error message is recorded there.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclListObjCopy(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listObj) /* List object for which an element array is
- * to be returned. */
-{
- Tcl_Obj *copyObj;
-
- if (!TclHasInternalRep(listObj, &tclListType)) {
- if (TclObjTypeHasProc(listObj, lengthProc)) {
- return Tcl_DuplicateObj(listObj);
- }
- if (SetListFromAny(interp, listObj) != TCL_OK) {
- return NULL;
- }
- }
-
- TclNewObj(copyObj);
- TclInvalidateStringRep(copyObj);
- DupListInternalRep(listObj, copyObj);
- return copyObj;
-}
/*
*------------------------------------------------------------------------
*
* ListRepRange --
@@ -1388,17 +1412,17 @@
*
*------------------------------------------------------------------------
*/
static void
ListRepRange(
- ListRep *srcRepPtr, /* Contains source of the range */
- Tcl_Size rangeStart, /* Index of first element to include */
- Tcl_Size rangeEnd, /* Index of last element to include */
- int preserveSrcRep, /* If true, srcRepPtr contents must not be
- * modified (generally because a shared Tcl_Obj
- * references it) */
- ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
+ 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;
@@ -1410,23 +1434,23 @@
if (!preserveSrcRep) {
/* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
ListRepFreeUnreferenced(srcRepPtr);
} /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
- if (rangeStart < 0) {
- rangeStart = 0;
+ if (fromIdx < 0) {
+ fromIdx = 0;
}
- if (rangeEnd >= numSrcElems) {
- rangeEnd = numSrcElems - 1;
+ if (toIdx >= numSrcElems) {
+ toIdx = numSrcElems - 1;
}
- if (rangeStart > rangeEnd) {
+ if (fromIdx > toIdx) {
/* Empty list of capacity 1. */
ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
return;
}
- rangeLen = rangeEnd - rangeStart + 1;
+ 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
@@ -1441,34 +1465,34 @@
*
* Note: Even if nothing below cause any changes, we still want the
* string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
* be returned as is even if the range encompasses the whole list.
*/
- if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
+ 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 (rangeStart == 0 && (!preserveSrcRep)
+ } 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 - (rangeEnd + 1);
- /* Assert: Because numSrcElems > rangeEnd earlier */
+ numAfterRangeEnd = numSrcElems - (toIdx + 1);
+ /* Assert: Because numSrcElems > toIdx earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-1.{8,9} */
- ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ 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) + rangeStart;
+ 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;
@@ -1493,12 +1517,12 @@
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
- ListRepInit(rangeLen, &srcElems[rangeStart], LISTREP_PANIC_ON_FAIL,
- rangeRepPtr);
+ 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.
@@ -1514,24 +1538,24 @@
LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* Free leading elements outside range */
- if (rangeStart != 0) {
+ if (fromIdx != 0) {
/* T:listrep-1.4,3.15 */
- ObjArrayDecrRefs(srcElems, 0, rangeStart);
+ ObjArrayDecrRefs(srcElems, 0, fromIdx);
}
/* Ditto for trailing */
- numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
- /* Assert: Because numSrcElems > rangeEnd earlier */
+ numAfterRangeEnd = numSrcElems - (toIdx + 1);
+ /* Assert: Because numSrcElems > toIdx earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-3.17 */
- ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ ObjArrayDecrRefs(srcElems, toIdx + 1, numAfterRangeEnd);
}
memmove(&srcRepPtr->storePtr->slots[0],
&srcRepPtr->storePtr
- ->slots[srcRepPtr->storePtr->firstUsed + rangeStart],
+ ->slots[srcRepPtr->storePtr->firstUsed + fromIdx],
rangeLen * sizeof(Tcl_Obj *));
srcRepPtr->storePtr->firstUsed = 0;
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
if (srcRepPtr->spanPtr) {
@@ -1569,46 +1593,70 @@
* 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;
+ }
-Tcl_Obj *
-TclListObjRange(
- Tcl_Interp *interp, /* May be NULL. Used for error messages */
- Tcl_Obj *listObj, /* List object to take a range from. */
- Tcl_Size rangeStart, /* Index of first element to include. */
- Tcl_Size rangeEnd) /* Index of last element to include. */
+ 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;
- if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
- return NULL;
+ int isShared, status;
+ status = TclListObjGetRep(interp, listPtr, &listRep);
+ if (status != TCL_OK) {
+ return status;
}
- isShared = Tcl_IsShared(listObj);
+ isShared = Tcl_IsShared(listPtr);
- ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
+ 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(listObj);
+ TclNewObj(listPtr);
} /* T:listrep-1.{4.3,5.1,5.2} */
- ListObjReplaceRepAndInvalidate(listObj, &resultRep);
- return listObj;
+ 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 'tclListType' and that index is valid for the
+ * that ObjPtr of of type 'tclListTypePtr' and that index is valid for the
* list.
*
*----------------------------------------------------------------------
*/
@@ -1648,30 +1696,54 @@
* 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(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *objPtr, /* 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
- * pointers to the list's objects. */
+Tcl_ListObjGetElements(tclObjTypeInterfaceArgsListAll)
+{
+ return TclObjectDispatch(listPtr, ListObjInterfaceGetElements,
+ list, all, interp, listPtr, objcPtr, objvPtr);
+}
+
+int
+ListObjInterfaceGetElements(tclObjTypeInterfaceArgsListAll)
{
ListRep listRep;
- if (TclObjTypeHasProc(objPtr, getElementsProc)) {
- return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
- }
- if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (TclListObjGetRep(interp, listPtr, &listRep) != TCL_OK)
+ return TCL_ERROR;
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
/*
@@ -1695,32 +1767,51 @@
* toObj's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
int
-Tcl_ListObjAppendList(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *toObj, /* List object to append elements to. */
- Tcl_Obj *fromObj) /* List obj with elements to append. */
-{
- Tcl_Size objc;
- Tcl_Obj **objv;
-
- if (Tcl_IsShared(toObj)) {
+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 (TclListObjGetElements(interp, fromObj, &objc, &objv) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Insert the new elements starting after the lists's last element.
- * Delete zero existing elements.
- */
-
- return TclListObjAppendElements(interp, toObj, objc, objv);
+ 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);
+ }
+}
}
/*
*------------------------------------------------------------------------
*
@@ -1900,10 +1991,24 @@
*
*----------------------------------------------------------------------
*/
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. */
{
/*
@@ -1941,37 +2046,35 @@
* If 'listPtr' is not already of type 'tclListType', it is converted.
*
*----------------------------------------------------------------------
*/
int
-Tcl_ListObjIndex(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listObj, /* List object to index into. */
- Tcl_Size index, /* Index of element to return. */
- Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
+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 (listObj->bytes == &tclEmptyString) {
- *objPtrPtr = NULL;
+ if (listPtr->bytes == &tclEmptyString) {
+ *resPtrPtr = NULL;
return TCL_OK;
}
- int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0;
- if (hasAbstractList) {
- return TclObjTypeIndex(interp, listObj, index, objPtrPtr);
- }
-
- if (TclListObjGetElements(interp, listObj, &numElems, &elemObjs) != TCL_OK) {
+ if (TclListObjGetElements(interp, listPtr, &numElems, &elemObjs)
+ != TCL_OK) {
return TCL_ERROR;
}
if ((index < 0) || (index >= numElems)) {
- *objPtrPtr = NULL;
+ *resPtrPtr = NULL;
} else {
- *objPtrPtr = elemObjs[index];
+ *resPtrPtr = elemObjs[index];
}
return TCL_OK;
}
@@ -1978,13 +2081,12 @@
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjLength --
*
- * This function returns the number of elements in a list object. If the
- * object is not already a list object, an attempt will be made to
- * convert it to one.
+ * 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
@@ -1994,47 +2096,29 @@
* Side effects:
* The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
-
#undef Tcl_ListObjLength
int
-Tcl_ListObjLength(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listObj, /* List object whose #elements to return. */
- Tcl_Size *lenPtr) /* The resulting length is stored here. */
+Tcl_ListObjLength(tclObjTypeInterfaceArgsListLength)
{
+ return TclObjectDispatch(listPtr, ListObjInterfaceLength,
+ list, length, interp, listPtr, lenPtr);
+}
+
+int
+ListObjInterfaceLength(tclObjTypeInterfaceArgsListLength) {
ListRep listRep;
- /* Empty string => empty list. Avoid unnecessary shimmering */
- if (listObj->bytes == &tclEmptyString) {
- *lenPtr = 0;
- return TCL_OK;
- }
-
- if (TclObjTypeHasProc(listObj, lengthProc)) {
- *lenPtr = TclObjTypeLength(listObj);
- return TCL_OK;
- }
-
- if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ if (TclListObjGetRep(interp, listPtr, &listRep) != TCL_OK) {
return TCL_ERROR;
}
*lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
-static Tcl_Size
-ListLength(
- Tcl_Obj *listPtr)
-{
- ListRep listRep;
- ListObjGetRep(listPtr, &listRep);
-
- return ListRepLength(&listRep);
-}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjReplace --
@@ -2070,17 +2154,61 @@
* freed.
*
*----------------------------------------------------------------------
*/
int
-Tcl_ListObjReplace(
- 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. */
- Tcl_Obj *const insertObjs[])/* Tcl objects to insert */
+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;
@@ -2093,15 +2221,10 @@
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- if (TclObjTypeHasProc(listObj, replaceProc)) {
- return TclObjTypeReplace(interp, listObj, first,
- numToDelete, numToInsert, insertObjs);
- }
-
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
/* Cannot be converted to a list */
return TCL_ERROR;
}
@@ -2530,17 +2653,28 @@
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 --
*
- * This procedure handles the 'lindex' command when objc==3.
+ * 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.
@@ -2565,48 +2699,59 @@
{
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, &tclListType)
+ 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);
}
/*
- * Here we make a private copy of the index list argument to avoid any
- * shimmering issues that might invalidate the indices array below while
- * we are still using it. This is probably unnecessary. It does not appear
- * that any damaging shimmering 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.
+ * 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 = TclListObjCopy(NULL, argObj);
- if (indexListCopy == NULL) {
+ 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);
}
- TclListObjGetElements(interp, indexListCopy, &numIndexObjs, &indexObjs);
listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
return listObj;
}
@@ -2644,35 +2789,10 @@
* represent the indices in the list. */
{
int status;
Tcl_Size i;
- /* Handle AbstractList as special case */
- if (TclObjTypeHasProc(listObj,indexProc)) {
- Tcl_Size listLen = TclObjTypeLength(listObj);
- Tcl_Size index;
- Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */
- for (i=0 ; i 0) {
- // TODO: support nested lists
- Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]);
- Tcl_DecrRefCount(elemObj);
- elemObj = e2Obj;
- }
- }
- Tcl_IncrRefCount(elemObj);
- return elemObj;
- }
-
Tcl_IncrRefCount(listObj);
for (i=0 ; i error. */
+ 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;
}
- }
-
- ListObjGetElements(listObj, listLen, elemPtrs);
- /* increment this reference count first before decrementing
- * just in case they are the same Tcl_Obj
- */
- itemObj = elemPtrs[index];
- Tcl_IncrRefCount(itemObj);
- Tcl_DecrRefCount(listObj);
- /* Extract the pointer to the appropriate element. */
- listObj = itemObj;
+ } 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;
}
@@ -2767,69 +2914,59 @@
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 *retValueObj; /* Pointer to the list to be returned. */
+ 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, &tclListType)
- && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
- == TCL_OK) {
- if (TclObjTypeHasProc(listObj, setElementProc)) {
- indices = &indexArgObj;
- retValueObj = TclObjTypeSetElement(
- interp, listObj, 1, indices, valueObj);
- if (retValueObj) {
- Tcl_IncrRefCount(retValueObj);
- }
- } else {
- /* indexArgPtr designates a single index. */
- /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
- retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- }
-
- } else {
-
- indexListCopy = TclListObjCopy(NULL,indexArgObj);
- if (!indexListCopy) {
- /*
- * indexArgPtr designates something that is neither an index nor a
- * well formed list. Report the error via TclLsetFlat.
- */
- retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- } else {
- if (TCL_OK != 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.
- */
- retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- } else {
-
- /*
- * Let TclLsetFlat perform the actual lset operation.
- */
-
- retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
- if (indexListCopy) {
- Tcl_DecrRefCount(indexListCopy);
- }
- }
- }
- }
- assert (retValueObj==NULL || retValueObj->typePtr || retValueObj->bytes);
- return retValueObj;
+ 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;
}
/*
*----------------------------------------------------------------------
*
@@ -2837,48 +2974,35 @@
*
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
* Results:
- * Returns the new value of the list variable, or NULL if an error
- * occurred. The returned object includes one reference count for the
- * pointer returned.
+ * 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:
- * On entry, the reference count of the variable value does not reflect
- * any references held on the stack. The first action of this function is
- * to determine whether the object is shared, and to duplicate it if it
- * is. The reference count of the duplicate is incremented. At this
- * point, the reference count will be 1 for either case, so that the
- * object will appear to be unshared.
- *
- * If an error occurs, and the object has been duplicated, the reference
- * count on the duplicate is decremented so that it is now 0: this
- * dismisses any memory that was allocated by this function.
- *
- * If no error occurs, the reference count of the original object is
- * incremented if the object has not been duplicated, and nothing is done
- * to a reference count of the duplicate. Now the reference count of an
- * unduplicated object is 2 (the returned pointer, plus the one stored in
- * the variable). The reference count of a duplicate object is 1,
- * reflecting that the returned pointer is the only active reference. The
- * caller is expected to store the returned value back in the variable
- * and decrement its reference count. (INST_STORE_* does exactly this.)
+ * 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.
*
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclLsetFlat(
- 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'. */
+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 result;
+ int copied = 0, result;
Tcl_Obj *subListObj, *retValueObj;
Tcl_Obj *pendingInvalidates[10];
Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
Tcl_Size numPendingInvalidates = 0;
@@ -2887,28 +3011,25 @@
* indices, [lset] is a synonym for [set].
* [lpop] does not use this but protect for NULL valueObj just in case.
*/
if (indexCount == 0) {
- if (valueObj != NULL) {
- Tcl_IncrRefCount(valueObj);
- }
- return valueObj;
+ *resPtrPtr = valueObj;
+ return TCL_OK;
}
/*
- * If the list is shared, make a copy we can modify (copy-on-write). We
- * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
- * 1) we have not yet confirmed listObj is actually a list; 2) We make a
- * verbatim copy of any existing string rep, and when we combine that with
- * the delayed invalidation of string reps of modified Tcl_Obj's
- * implemented below, the outcome is that any error condition that causes
- * this routine to return NULL, will leave the string rep of listObj and
- * all elements to be unchanged.
+ * 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) ? Tcl_DuplicateObj(listObj) : listObj;
+ 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.
*/
@@ -2978,14 +3099,13 @@
result = TCL_ERROR;
break;
}
/*
- * No error conditions. As long as we're not yet on the last index,
- * determine the next sublist for the next pass through the loop,
- * and take steps to make sure it is an unshared copy, as we intend
- * to modify it.
+ * 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) {
@@ -2992,11 +3112,17 @@
TclNewObj(subListObj);
} else {
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
- subListObj = Tcl_DuplicateObj(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
@@ -3010,11 +3136,22 @@
Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
- subListObj = Tcl_DuplicateObj(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
@@ -3079,11 +3216,12 @@
*/
if (retValueObj != listObj) {
Tcl_DecrRefCount(retValueObj);
}
- return NULL;
+ *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
@@ -3101,12 +3239,12 @@
} else {
/* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
TclListObjSetElement(NULL, subListObj, index, valueObj);
TclInvalidateStringRep(subListObj);
}
- Tcl_IncrRefCount(retValueObj);
- return retValueObj;
+ *resPtrPtr = retValueObj;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -3131,18 +3269,18 @@
* ref count of the replacement object.
*
*----------------------------------------------------------------------
*/
int
-TclListObjSetElement(
- 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. */
+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. */
@@ -3195,11 +3333,10 @@
Tcl_DecrRefCount(elemPtrs[index]);
elemPtrs[index] = valueObj;
/* Internal rep may be cloned so replace */
ListObjReplaceRepAndInvalidate(listObj, &listRep);
-
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -3263,11 +3400,11 @@
}
/*
*----------------------------------------------------------------------
*
- * SetListFromAny --
+ * 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
@@ -3278,12 +3415,12 @@
* If no error occurs, a list is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
-static int
-SetListFromAny(
+int
+TclSetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Tcl_Obj **elemPtrs;
ListRep listRep;
@@ -3294,11 +3431,65 @@
* 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 (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) {
+ 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;
@@ -3333,39 +3524,13 @@
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
- } else if (TclObjTypeHasProc(objPtr,indexProc)) {
- Tcl_Size elemCount, i;
-
- elemCount = TclObjTypeLength(objPtr);
-
- if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) {
- return TCL_ERROR;
- }
-
- LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
- LIST_ASSERT(listRep.storePtr->firstUsed == 0);
-
- elemPtrs = listRep.storePtr->slots;
-
- /* Each iteration, store a list element */
- for (i = 0; i < elemCount; i++) {
- if (TclObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
- }
-
- LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount);
-
- listRep.storePtr->numUsed = elemCount;
-
} else {
Tcl_Size estCount, length;
- const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
+ const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
@@ -3439,11 +3604,11 @@
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
- objPtr->typePtr = &tclListType;
+ objPtr->typePtr = tclListTypePtr;
return TCL_OK;
}
/*
@@ -3520,11 +3685,11 @@
/* 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 = TclGetStringFromObj(elemPtrs[i], &length);
+ 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);
}
}
@@ -3536,11 +3701,11 @@
start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
- elem = TclGetStringFromObj(elemPtrs[i], &length);
+ 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 */
Index: generic/tclLiteral.c
==================================================================
--- generic/tclLiteral.c
+++ generic/tclLiteral.c
@@ -1,19 +1,30 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
#include "tclCompile.h"
@@ -209,11 +220,11 @@
*
* https://stackoverflow.com/q/54337750/301832
*/
Tcl_Size objLength;
- const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
+ const char *objBytes = Tcl_GetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
&& (memcmp(objBytes, bytes, length) == 0)))) {
/*
@@ -515,11 +526,11 @@
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *entryPtr;
const char *bytes;
size_t globalHash, length;
- bytes = TclGetStringFromObj(objPtr, &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;
@@ -577,11 +588,11 @@
newObjPtr = Tcl_DuplicateObj(lPtr->objPtr);
Tcl_IncrRefCount(newObjPtr);
TclReleaseLiteral(interp, lPtr->objPtr);
lPtr->objPtr = newObjPtr;
- bytes = TclGetStringFromObj(newObjPtr, &length);
+ 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) {
@@ -714,11 +725,11 @@
}
}
}
if (!found) {
- bytes = TclGetStringFromObj(objPtr, &length);
+ 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*/
@@ -844,11 +855,11 @@
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
- bytes = TclGetStringFromObj(objPtr, &length);
+ 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
@@ -1017,11 +1028,11 @@
* 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 = TclGetStringFromObj(entryPtr->objPtr, &length);
+ bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
index = (HashString(bytes, length) & tablePtr->mask);
*oldChainPtr = entryPtr->nextPtr;
bucketPtr = &tablePtr->buckets[index];
entryPtr->nextPtr = *bucketPtr;
@@ -1188,11 +1199,11 @@
for (i=0 ; inumBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != TCL_INDEX_NONE) {
- bytes = TclGetStringFromObj(localPtr->objPtr, &length);
+ 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) {
@@ -1237,11 +1248,11 @@
for (i=0 ; inumBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
- bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
+ 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) {
Index: generic/tclLoad.c
==================================================================
--- generic/tclLoad.c
+++ generic/tclLoad.c
@@ -1,17 +1,28 @@
/*
- * tclLoad.c --
- *
- * This file provides the generic portion (those that are the same on all
- * platforms) of Tcl's dynamic loading facilities.
- *
* 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
Index: generic/tclLoadNone.c
==================================================================
--- generic/tclLoadNone.c
+++ generic/tclLoadNone.c
@@ -1,17 +1,28 @@
/*
- * 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.
- *
* 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"
/*
*----------------------------------------------------------------------
*
Index: generic/tclMain.c
==================================================================
--- generic/tclMain.c
+++ generic/tclMain.c
@@ -1,21 +1,32 @@
+/*
+ * 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.
- *
- * 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.
*/
/*
* 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
Index: generic/tclNamesp.c
==================================================================
--- generic/tclNamesp.c
+++ generic/tclNamesp.c
@@ -1,14 +1,6 @@
/*
- * 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.
- *
* 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.
@@ -21,10 +13,29 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
/*
@@ -129,11 +140,11 @@
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetNsNameFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define NsNameSetInternalRep(objPtr, nnPtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -393,11 +404,11 @@
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
Tcl_Free(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
- if (framePtr->numCompiledLocals > 0) {
+ if (framePtr->numCompiledLocals + 1 > 1) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
@@ -2231,11 +2242,11 @@
* 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, *lastNsPtr = NULL, *lastAltNsPtr = NULL;
+ Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
const char *start, *end;
const char *nsName;
Tcl_HashEntry *entryPtr;
@@ -2372,16 +2383,12 @@
TclPopStackFrame(interp);
if (nsPtr == NULL) {
Tcl_Panic("Could not create namespace '%s'", nsName);
}
- } else {
- /*
- * Namespace not found and was not created.
- * Remember last found namespace for TCL_FIND_IF_NOT_SIMPLE.
- */
- lastNsPtr = nsPtr;
+ } else { /* Namespace not found and was not
+ * created. */
nsPtr = NULL;
}
}
/*
@@ -2399,32 +2406,19 @@
}
#endif
if (entryPtr != NULL) {
altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else {
- /* Remember last found in alternate path */
- lastAltNsPtr = altNsPtr;
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
*/
if ((nsPtr == NULL) && (altNsPtr == NULL)) {
- if (flags & TCL_FIND_IF_NOT_SIMPLE) {
- /*
- * return last found NS, regardless simple name or not,
- * e. g. ::A::B::C::D -> ::A::B and C::D, if namespace C
- * cannot be found in ::A::B
- */
- nsPtr = lastNsPtr;
- altNsPtr = lastAltNsPtr;
- *simpleNamePtr = start;
- goto done;
- }
*simpleNamePtr = NULL;
goto done;
}
start = end;
@@ -3169,11 +3163,11 @@
* [::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 = TclGetStringFromObj(objv[1], &length);
+ arg = Tcl_GetStringFromObj(objv[1], &length);
if (*arg==':' && length > 20
&& strncmp(arg, "::namespace inscope ", 20) == 0) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -3931,10 +3925,11 @@
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;
}
@@ -3947,11 +3942,15 @@
if (origCmd == NULL) {
origCmd = cmd;
}
TclNewObj(resultPtr);
Tcl_GetCommandFullName(interp, origCmd, resultPtr);
- if (TclCheckEmptyString(resultPtr) == TCL_EMPTYSTRING_YES ) {
+ status = TclCheckEmptyString(interp ,resultPtr, &isEmpty);
+ if (status) {
+ return TCL_ERROR;
+ }
+ if (isEmpty == TCL_EMPTYSTRING_YES ) {
Tcl_DecrRefCount(resultPtr);
namespaceOriginError:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid command name \"%s\"", TclGetString(objv[1])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
Index: generic/tclNotify.c
==================================================================
--- generic/tclNotify.c
+++ generic/tclNotify.c
@@ -1,23 +1,34 @@
/*
- * 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.
- *
* 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).
Index: generic/tclOO.c
==================================================================
--- generic/tclOO.c
+++ generic/tclOO.c
@@ -1,17 +1,28 @@
/*
- * tclOO.c --
- *
- * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
- *
* 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"
@@ -136,13 +147,10 @@
* Scripted parts of TclOO. First, the main script (cannot be outside this
* file).
*/
static const char initScript[] =
-#ifndef TCL_NO_DEPRECATED
-"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
-#endif
"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
"namespace eval ::oo { variable version " TCLOO_VERSION " };"
"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/* "tcl_findLibrary tcloo $oo::version $oo::version" */
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
@@ -258,14 +266,10 @@
if (Tcl_EvalEx(interp, initScript, TCL_INDEX_NONE, 0) != TCL_OK) {
return TCL_ERROR;
}
-#ifndef TCL_NO_DEPRECATED
- Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
- &tclOOStubs);
-#endif
return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL,
&tclOOStubs);
}
/*
Index: generic/tclOO.decls
==================================================================
--- generic/tclOO.decls
+++ generic/tclOO.decls
@@ -1,16 +1,24 @@
+# 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.
#
-# 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.
library tclOO
######################################################################
# Public API, exposed for general users of TclOO.
Index: generic/tclOO.h
==================================================================
--- generic/tclOO.h
+++ generic/tclOO.h
@@ -1,17 +1,28 @@
/*
- * tclOO.h --
- *
- * This file contains the public API definitions and some of the function
- * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
- *
* Copyright (c) 2006-2010 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
@@ -60,16 +71,12 @@
* 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);
-#if TCL_MAJOR_VERSION > 8
typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv);
-#else
-#define Tcl_MethodCallProc2 Tcl_MethodCallProc
-#endif
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,
@@ -96,11 +103,10 @@
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;
-#if TCL_MAJOR_VERSION > 8
typedef struct {
int version; /* Structure version field. Always to be equal
* to TCL_OO_METHOD_VERSION_2 in
* declarations. */
const char *name; /* Name of this type of method, mostly for
@@ -113,13 +119,10 @@
* 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;
-#else
-#define Tcl_MethodType2 Tcl_MethodType
-#endif
/*
* 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.
Index: generic/tclOOBasic.c
==================================================================
--- generic/tclOOBasic.c
+++ generic/tclOOBasic.c
@@ -1,17 +1,28 @@
/*
- * tclOOBasic.c --
- *
- * This file contains implementations of the "simple" commands and
- * methods from the object-system core.
- *
* 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"
Index: generic/tclOOCall.c
==================================================================
--- generic/tclOOCall.c
+++ generic/tclOOCall.c
@@ -1,16 +1,27 @@
+/*
+ * 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.
- *
- * 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.
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
@@ -151,11 +162,11 @@
"TclOO method name",
FreeMethodNameRep,
DupMethodNameRep,
NULL,
NULL,
- TCL_OBJTYPE_V0
+ 0
};
/*
* ----------------------------------------------------------------------
*
Index: generic/tclOODecls.h
==================================================================
--- generic/tclOODecls.h
+++ generic/tclOODecls.h
@@ -1,8 +1,18 @@
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
@@ -268,16 +278,6 @@
#endif /* defined(USE_TCLOO_STUBS) */
/* !END!: Do not edit above this line. */
-#if TCL_MAJOR_VERSION < 9
- /* TIP #630 for 8.7 */
-# undef Tcl_MethodIsType2
-# define Tcl_MethodIsType2 Tcl_MethodIsType
-# undef Tcl_NewInstanceMethod2
-# define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod
-# undef Tcl_NewMethod2
-# define Tcl_NewMethod2 Tcl_NewMethod
-#endif
-
#endif /* _TCLOODECLS */
Index: generic/tclOODefineCmds.c
==================================================================
--- generic/tclOODefineCmds.c
+++ generic/tclOODefineCmds.c
@@ -1,17 +1,28 @@
/*
- * tclOODefineCmds.c --
- *
- * This file contains the implementation of the ::oo::define command,
- * part of the object-system core (NB: not Tcl_Obj, but ::oo).
- *
* Copyright © 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"
@@ -769,11 +780,11 @@
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
- soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
+ soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
@@ -831,11 +842,11 @@
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
Tcl_Size length;
- const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
+ const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
/*
@@ -1052,11 +1063,11 @@
* was being configured. */
{
Tcl_Size length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
- const char *objName = TclGetStringFromObj(realNameObj, &length);
+ 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)",
@@ -1604,11 +1615,11 @@
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
- (void)TclGetStringFromObj(objv[2], &bodyLength);
+ (void)Tcl_GetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
@@ -1810,11 +1821,11 @@
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
- (void)TclGetStringFromObj(objv[1], &bodyLength);
+ (void)Tcl_GetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
Index: generic/tclOOInfo.c
==================================================================
--- generic/tclOOInfo.c
+++ generic/tclOOInfo.c
@@ -1,17 +1,28 @@
/*
- * tclOODefineCmds.c --
- *
- * This file contains the implementation of the ::oo-related [info]
- * subcommands.
- *
* 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"
Index: generic/tclOOInt.h
==================================================================
--- generic/tclOOInt.h
+++ generic/tclOOInt.h
@@ -1,17 +1,28 @@
/*
- * tclOOInt.h --
- *
- * This file contains the structure definitions and some of the function
- * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
- *
* Copyright (c) 2006-2012 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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"
Index: generic/tclOOIntDecls.h
==================================================================
--- generic/tclOOIntDecls.h
+++ generic/tclOOIntDecls.h
@@ -1,8 +1,18 @@
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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. */
Index: generic/tclOOMethod.c
==================================================================
--- generic/tclOOMethod.c
+++ generic/tclOOMethod.c
@@ -1,16 +1,27 @@
/*
- * tclOOMethod.c --
- *
- * This file contains code to create and manage methods.
- *
* 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"
Index: generic/tclOOScript.h
==================================================================
--- generic/tclOOScript.h
+++ generic/tclOOScript.h
@@ -1,20 +1,31 @@
/*
- * tclOOScript.h --
- *
- * This file contains support scripts for TclOO. They are defined here so
- * that the code can be definitely run even in safe interpreters; TclOO's
- * core setup is safe.
- *
* Copyright (c) 2012-2018 Donal K. Fellows
* Copyright (c) 2013 Andreas Kupries
* Copyright (c) 2017 Gerald Lester
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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.
Index: generic/tclOOStubInit.c
==================================================================
--- generic/tclOOStubInit.c
+++ generic/tclOOStubInit.c
@@ -1,5 +1,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 (mostly) automatically generated from tclOO.decls.
* It is compiled and linked in with the tclOO package proper.
*/
Index: generic/tclOOStubLib.c
==================================================================
--- generic/tclOOStubLib.c
+++ generic/tclOOStubLib.c
@@ -1,5 +1,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.
+*/
+
/*
* ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
*/
#include "tclOOInt.h"
Index: generic/tclObj.c
==================================================================
--- generic/tclObj.c
+++ generic/tclObj.c
@@ -1,33 +1,50 @@
/*
- * tclObj.c --
- *
- * This file contains Tcl object-related functions that are used by many
- * Tcl commands.
- *
* 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
+ * 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
#include
+
/*
* 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.
*/
@@ -200,10 +217,13 @@
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.
*/
@@ -215,50 +235,93 @@
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 Tcl_ObjType tclBooleanType= {
+const ObjectType tclBooleanObjType= {
"boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- TclSetBooleanFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V1(TclLengthOne)
+ TclSetBooleanFromAny, /* setFromAnyProc */
+ 2,
+ (Tcl_ObjInterface *)&tclScalarInterface
};
-const Tcl_ObjType tclDoubleType= {
+
+
+MODULE_SCOPE const Tcl_ObjType *tclBooleanType = (Tcl_ObjType *)&tclBooleanObjType;
+
+const ObjectType tclDoubleObjType= {
"double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V1(TclLengthOne)
+ 2,
+ (Tcl_ObjInterface *)&tclScalarInterface
};
-const Tcl_ObjType tclIntType = {
+
+MODULE_SCOPE const Tcl_ObjType *tclDoubleType = (Tcl_ObjType *)&tclDoubleObjType;
+
+const ObjectType tclIntObjType = {
"int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V1(TclLengthOne)
+ 2,
+ (Tcl_ObjInterface *)&tclScalarInterface
};
-const Tcl_ObjType tclBignumType = {
+
+MODULE_SCOPE const Tcl_ObjType *tclIntType = (Tcl_ObjType *)&tclIntObjType;
+
+const ObjectType tclBignumObjType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V1(TclLengthOne)
+ 2,
+ (Tcl_ObjInterface *)&tclScalarInterface
};
+
+MODULE_SCOPE const Tcl_ObjType *tclBignumType = (Tcl_ObjType *)&tclBignumObjType;
/*
* The structure below defines the Tcl obj hash key type.
*/
@@ -298,11 +361,11 @@
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetCmdNameFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 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
@@ -374,14 +437,14 @@
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
- Tcl_RegisterObjType(&tclDoubleType);
+ Tcl_RegisterObjType(tclDoubleType);
Tcl_RegisterObjType(&tclStringType);
- Tcl_RegisterObjType(&tclListType);
- Tcl_RegisterObjType(&tclDictType);
+ Tcl_RegisterObjType(tclListTypePtr);
+ Tcl_RegisterObjType(tclDictTypePtr);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
@@ -634,11 +697,11 @@
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
- (void)TclGetStringFromObj(objPtr, &length);
+ (void)Tcl_GetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
@@ -782,10 +845,23 @@
}
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 --
@@ -801,10 +877,29 @@
* 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
@@ -811,12 +906,13 @@
* forever). */
{
int isNew;
Tcl_MutexLock(&tableMutex);
+ const char *name = TclObjTypeName(typePtr);
Tcl_SetHashValue(
- Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr);
+ Tcl_CreateHashEntry(&typeTable, name, &isNew), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
@@ -938,11 +1034,11 @@
if (objPtr->typePtr == typePtr) {
return TCL_OK;
}
/*
- * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form
+ * 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) {
@@ -1513,10 +1609,18 @@
*
* 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:
@@ -1564,10 +1668,117 @@
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)
@@ -1636,11 +1847,11 @@
}
/*
*----------------------------------------------------------------------
*
- * Tcl_GetStringFromObj/TclGetStringFromObj --
+ * Tcl_GetStringFromObj
*
* Returns the string representation's byte array pointer and length for
* an object.
*
* Results:
@@ -1656,57 +1867,10 @@
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
-#if !defined(TCL_NO_DEPRECATED)
-#undef TclGetStringFromObj
-char *
-TclGetStringFromObj(
- Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
- * be returned. */
- void *lengthPtr) /* If non-NULL, the location where the string
- * rep's byte array length should * be stored.
- * If NULL, no length is stored. */
-{
- if (objPtr->bytes == NULL) {
- /*
- * Note we do not check for objPtr->typePtr == NULL. An invariant
- * of a properly maintained Tcl_Obj is that at least one of
- * objPtr->bytes and objPtr->typePtr must not be NULL. If broken
- * extensions fail to maintain that invariant, we can crash here.
- */
-
- if (objPtr->typePtr->updateStringProc == NULL) {
- /*
- * Those Tcl_ObjTypes which choose not to define an
- * updateStringProc must be written in such a way that
- * (objPtr->bytes) never becomes NULL.
- */
- Tcl_Panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- objPtr->typePtr->updateStringProc(objPtr);
- if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE
- || objPtr->bytes[objPtr->length] != '\0') {
- Tcl_Panic("UpdateStringProc for type '%s' "
- "failed to create a valid string rep",
- objPtr->typePtr->name);
- }
- }
- if (lengthPtr != NULL) {
- if (objPtr->length > INT_MAX) {
- Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr"
- " cannot handle such long strings. Please use 'Tcl_Size'");
- }
- *(int *)lengthPtr = (int)objPtr->length;
- }
- return objPtr->bytes;
-}
-#endif /* !defined(TCL_NO_DEPRECATED) */
-
-#undef Tcl_GetStringFromObj
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
@@ -1714,11 +1878,11 @@
* 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
+ * 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) {
@@ -1995,11 +2159,10 @@
* The internalrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
-#undef Tcl_GetBoolFromObj
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,
@@ -2018,15 +2181,15 @@
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
- if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) {
+ if (TclHasInternalRep(objPtr, tclIntType) || TclHasInternalRep(objPtr, tclBooleanType)) {
result = (objPtr->internalRep.wideValue != 0);
goto boolEnd;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
/*
* 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
@@ -2039,11 +2202,11 @@
return TCL_ERROR;
}
result = (d != 0.0);
goto boolEnd;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
result = 1;
boolEnd:
if (charPtr != NULL) {
flags &= (TCL_NULL_OK-2);
if (flags) {
@@ -2065,11 +2228,10 @@
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
}
-#undef Tcl_GetBooleanFromObj
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int *intPtr) /* Place to store resulting boolean. */
@@ -2107,22 +2269,22 @@
* whether a boolean conversion is possible without generating the string
* rep.
*/
if (objPtr->bytes == NULL) {
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
goto badBoolean;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
goto badBoolean;
}
}
if (ParseBoolean(objPtr) == TCL_OK) {
@@ -2249,17 +2411,17 @@
*/
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
- objPtr->typePtr = &tclBooleanType;
+ objPtr->typePtr = tclBooleanType;
return TCL_OK;
numericBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
- objPtr->typePtr = &tclIntType;
+ objPtr->typePtr = tclIntType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -2347,11 +2509,11 @@
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
- objPtr->typePtr = &tclDoubleType;
+ objPtr->typePtr = tclDoubleType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
@@ -2420,11 +2582,11 @@
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, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
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",
@@ -2433,15 +2595,15 @@
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
@@ -2565,10 +2727,23 @@
}
*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 --
@@ -2650,16 +2825,16 @@
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, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#else
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
/*
* 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
@@ -2674,20 +2849,20 @@
return TCL_OK;
}
goto tooLarge;
}
#endif
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
/*
* 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.
@@ -2978,24 +3153,24 @@
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
do {
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
*/
@@ -3063,11 +3238,11 @@
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr)
/* Place to store resulting long. */
{
do {
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
if (objPtr->internalRep.wideValue < 0) {
wideUIntOutOfRange:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected unsigned integer but got \"%s\"",
@@ -3077,14 +3252,14 @@
return TCL_ERROR;
}
*wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
goto wideUIntOutOfRange;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideUInt, even when auto-narrowing is enabled.
*/
@@ -3147,24 +3322,24 @@
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, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
}
return TCL_ERROR;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
mp_int big;
mp_err err;
Tcl_WideUInt value = 0, scratch;
size_t numBytes;
@@ -3273,11 +3448,11 @@
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
- copyPtr->typePtr = &tclBignumType;
+ copyPtr->typePtr = tclBignumType;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
@@ -3443,11 +3618,11 @@
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, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
@@ -3468,18 +3643,18 @@
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", (void *)NULL);
@@ -3635,11 +3810,11 @@
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
- objPtr->typePtr = &tclBignumType;
+ objPtr->typePtr = tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
/*
* Clear the mp_int value.
*
@@ -3658,18 +3833,17 @@
* Tcl_GetNumberFromObj --
*
* Extracts a number (of any possible numeric type) from an object.
*
* Results:
- * Whether the extraction worked. The type is stored in the variable
- * referred to by the typePtr argument, and a pointer to the
- * representation is stored in the variable referred to by the
- * clientDataPtr.
+ * 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:
- * Can allocate thread-specific data for handling the copy-out space for
- * bignums; this space is shared within a thread.
+ * May allocate thread-specific data shared within a thread for handling
+ * the copy-out space for bignums.
*
*----------------------------------------------------------------------
*/
int
@@ -3678,25 +3852,25 @@
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
do {
- if (TclHasInternalRep(objPtr, &tclDoubleType)) {
+ if (TclHasInternalRep(objPtr, tclDoubleType)) {
if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclIntType)) {
+ if (TclHasInternalRep(objPtr, tclIntType)) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (TclHasInternalRep(objPtr, &tclBignumType)) {
+ if (TclHasInternalRep(objPtr, tclBignumType)) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
@@ -4537,10 +4711,43 @@
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 --
@@ -4649,17 +4856,18 @@
* 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",
- objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ name,
objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
- if (TclHasInternalRep(objv[1], &tclDoubleType)) {
+ if (TclHasInternalRep(objv[1], tclDoubleType)) {
Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
objv[1]->internalRep.doubleValue);
} else {
Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
(void *) objv[1]->internalRep.twoPtrValue.ptr1,
@@ -4677,10 +4885,36 @@
}
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
ADDED generic/tclObjInterface.c
Index: generic/tclObjInterface.c
==================================================================
--- /dev/null
+++ generic/tclObjInterface.c
@@ -0,0 +1,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;
+}
Index: generic/tclOptimize.c
==================================================================
--- generic/tclOptimize.c
+++ generic/tclOptimize.c
@@ -1,16 +1,27 @@
/*
- * tclOptimize.c --
- *
- * This file contains the bytecode optimizer.
- *
* 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
/*
@@ -232,11 +243,11 @@
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
- (void) TclGetStringFromObj(litPtr, &numBytes);
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
@@ -247,11 +258,11 @@
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt4AtPtr(currentInstPtr + 1));
Tcl_Size numBytes;
- (void) TclGetStringFromObj(litPtr, &numBytes);
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
Index: generic/tclPanic.c
==================================================================
--- generic/tclPanic.c
+++ generic/tclPanic.c
@@ -1,20 +1,31 @@
/*
- * 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.
- *
* 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
Index: generic/tclParse.c
==================================================================
--- generic/tclParse.c
+++ generic/tclParse.c
@@ -1,20 +1,31 @@
/*
- * 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.
- *
* 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
/*
@@ -2204,11 +2215,11 @@
Tcl_Size clPos;
if (result == 0) {
clPos = 0;
} else {
- (void)TclGetStringFromObj(result, &clPos);
+ (void)Tcl_GetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (Tcl_Size *)Tcl_Realloc(clPosition,
@@ -2480,11 +2491,11 @@
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
Tcl_Size length;
- const char *script = TclGetStringFromObj(objPtr, &length);
+ const char *script = Tcl_GetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
Index: generic/tclParse.h
==================================================================
--- generic/tclParse.h
+++ generic/tclParse.h
@@ -1,5 +1,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.
+*/
+
/*
* Minimal set of shared macro definitions and declarations so that multiple
* source files can make use of the parsing table in tclParse.c
*/
Index: generic/tclPathObj.c
==================================================================
--- generic/tclPathObj.c
+++ generic/tclPathObj.c
@@ -1,16 +1,27 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
#include "tclFileSystem.h"
#include
@@ -43,11 +54,11 @@
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
/*
* struct FsPath --
*
@@ -222,11 +233,11 @@
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- (void)TclGetStringFromObj(retVal, &curLen);
+ (void)Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
dirSep += 2;
oldDirSep = dirSep;
@@ -248,11 +259,11 @@
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
- (void)TclGetStringFromObj(retVal, &curLen);
+ (void)Tcl_GetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
if (zipVolumeLen) {
@@ -282,11 +293,11 @@
* to retVal's directory. This means concatenating
* the link onto the directory of the path so far.
*/
const char *path =
- TclGetStringFromObj(retVal, &curLen);
+ Tcl_GetStringFromObj(retVal, &curLen);
while (curLen-- > 0) {
if (IsSeparatorOrNull(path[curLen])) {
break;
}
@@ -297,11 +308,11 @@
*/
Tcl_SetObjLength(retVal, curLen+1);
Tcl_AppendObjToObj(retVal, linkObj);
TclDecrRefCount(linkObj);
- linkStr = TclGetStringFromObj(retVal, &curLen);
+ linkStr = Tcl_GetStringFromObj(retVal, &curLen);
} else {
/*
* Absolute link.
*/
@@ -310,11 +321,11 @@
retVal = Tcl_DuplicateObj(linkObj);
TclDecrRefCount(linkObj);
} else {
retVal = linkObj;
}
- linkStr = TclGetStringFromObj(retVal, &curLen);
+ linkStr = Tcl_GetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
@@ -327,11 +338,11 @@
}
}
}
}
} else {
- linkStr = TclGetStringFromObj(retVal, &curLen);
+ 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
@@ -401,11 +412,11 @@
* Likewise for zipfs volumes.
*/
if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) {
int needTrailingSlash = 0;
Tcl_Size len;
- const char *path = TclGetStringFromObj(retVal, &len);
+ const char *path = Tcl_GetStringFromObj(retVal, &len);
if (zipVolumeLen) {
if (len == (zipVolumeLen - 1)) {
needTrailingSlash = 1;
}
} else {
@@ -583,11 +594,11 @@
* that special case here, but we don't, and instead just use
* the standardPath code.
*/
Tcl_Size numBytes;
- const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
@@ -620,11 +631,11 @@
* 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 = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
+ const char *rest = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
@@ -649,11 +660,11 @@
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
Tcl_Size length;
- fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
+ fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
/*
* There is no extension so the root is the same as the
@@ -701,11 +712,11 @@
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
Tcl_Size length;
const char *fileName, *extension;
- fileName = TclGetStringFromObj(pathPtr, &length);
+ fileName = Tcl_GetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
return pathPtr;
} else {
@@ -881,11 +892,11 @@
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
Tcl_Size len;
- str = TclGetStringFromObj(tailObj, &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!
@@ -953,11 +964,11 @@
Tcl_PathType type;
char *strElt, *ptr;
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
- strElt = TclGetStringFromObj(elt, &strEltLen);
+ 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) {
@@ -1050,11 +1061,11 @@
noQuickReturn:
if (res == NULL) {
TclNewObj(res);
}
- ptr = TclGetStringFromObj(res, &length);
+ 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.
@@ -1085,11 +1096,11 @@
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
- (void)TclGetStringFromObj(res, &length);
+ (void)Tcl_GetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + strlen(strElt));
ptr = TclGetString(res) + length;
for (; *strElt != '\0'; strElt++) {
@@ -1350,11 +1361,11 @@
* 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 = TclGetStringFromObj(tail, &length);
+ bytes = Tcl_GetStringFromObj(tail, &length);
if (length == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
TclpNativeJoinPath(copy, bytes);
}
@@ -1410,11 +1421,11 @@
*
* 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 = TclGetStringFromObj(cwdPtr, &cwdLen);
+ 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.
@@ -1430,11 +1441,11 @@
if (tempStr[cwdLen-1] != '/' && tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
}
- tempStr = TclGetStringFromObj(pathPtr, &len);
+ tempStr = Tcl_GetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
@@ -1655,11 +1666,11 @@
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
Tcl_Size len;
- const char *orig = TclGetStringFromObj(transPtr, &len);
+ const char *orig = Tcl_GetStringFromObj(transPtr, &len);
char *result = (char *)Tcl_Alloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
@@ -1715,11 +1726,11 @@
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
- (void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
+ (void)Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
copy = Tcl_DuplicateObj(dir);
}
@@ -1728,11 +1739,11 @@
/*
* We now own a reference on both 'dir' and 'copy'
*/
- (void) TclGetStringFromObj(dir, &cwdLen);
+ (void) Tcl_GetStringFromObj(dir, &cwdLen);
/* Normalize the combined string. */
if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) {
/*
@@ -1811,11 +1822,11 @@
Tcl_Size cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
- (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
+ (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!
@@ -2149,12 +2160,12 @@
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
- firstStr = TclGetStringFromObj(firstPtr, &firstLen);
- secondStr = TclGetStringFromObj(secondPtr, &secondLen);
+ firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
+ secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen)) {
return 1;
}
/*
@@ -2169,12 +2180,12 @@
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
- firstStr = TclGetStringFromObj(firstPtr, &firstLen);
- secondStr = TclGetStringFromObj(secondPtr, &secondLen);
+ firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
+ secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
return ((firstLen == secondLen) && !memcmp(firstStr, secondStr, firstLen));
}
/*
*---------------------------------------------------------------------------
@@ -2218,11 +2229,11 @@
* 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).
*/
- TclGetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */
+ 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.
@@ -2367,11 +2378,11 @@
copy = Tcl_DuplicateObj(copy);
}
Tcl_IncrRefCount(copy);
/* Steal copy's string rep */
- pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
+ pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
TclInitEmptyStringRep(copy);
TclDecrRefCount(copy);
}
@@ -2427,11 +2438,11 @@
* situation.
*/
Tcl_Size len;
- (void) TclGetStringFromObj(pathPtr, &len);
+ (void) Tcl_GetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
*/
@@ -2575,11 +2586,11 @@
const char *path;
Tcl_Size len;
Tcl_Size split;
Tcl_DString resolvedPath;
- path = TclGetStringFromObj(pathObj, &len);
+ path = Tcl_GetStringFromObj(pathObj, &len);
if (path[0] != '~') {
return pathObj;
}
/*
Index: generic/tclPipe.c
==================================================================
--- generic/tclPipe.c
+++ generic/tclPipe.c
@@ -1,17 +1,28 @@
/*
- * tclPipe.c --
- *
- * This file contains the generic portion of the command channel driver
- * as well as various utility routines used in managing subprocesses.
- *
* 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
Index: generic/tclPkg.c
==================================================================
--- generic/tclPkg.c
+++ generic/tclPkg.c
@@ -1,16 +1,32 @@
/*
- * tclPkg.c --
- *
- * This file implements package and version control for Tcl via the
- * "package" command and a few C APIs.
- *
* Copyright © 1996 Sun Microsystems, Inc.
* Copyright © 2006 Andreas Kupries
*
* 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.
*/
@@ -1181,11 +1197,11 @@
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
- argv3 = TclGetStringFromObj(objv[3], &length);
+ 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) {
@@ -1228,14 +1244,14 @@
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
}
if (iPtr->scriptFile) {
- argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
+ argv4 = Tcl_GetStringFromObj(iPtr->scriptFile, &length);
DupBlock(availPtr->pkgIndex, argv4, length + 1);
}
- argv4 = TclGetStringFromObj(objv[4], &length);
+ argv4 = Tcl_GetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, length + 1);
break;
}
case PKG_NAMES:
if (objc != 2) {
@@ -1408,11 +1424,11 @@
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
Tcl_Free(iPtr->packageUnknown);
}
- argv2 = TclGetStringFromObj(objv[2], &length);
+ argv2 = Tcl_GetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, length+1);
}
@@ -2073,11 +2089,11 @@
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i;
Tcl_Size length;
for (i = 0; i < reqc; i++) {
- const char *v = TclGetStringFromObj(reqv[i], &length);
+ 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 {
Index: generic/tclPkgConfig.c
==================================================================
--- generic/tclPkgConfig.c
+++ generic/tclPkgConfig.c
@@ -1,17 +1,28 @@
/*
- * tclPkgConfig.c --
- *
- * This file contains the configuration information to embed into the tcl
- * library.
- *
* Copyright © 2002 Andreas Kupries
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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"
Index: generic/tclPlatDecls.h
==================================================================
--- generic/tclPlatDecls.h
+++ generic/tclPlatDecls.h
@@ -1,12 +1,23 @@
+/*
+ * 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.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * All rights reserved.
*/
#ifndef _TCLPLATDECLS
#define _TCLPLATDECLS
@@ -46,97 +57,10 @@
# else
# define MODULE_SCOPE extern
# endif
#endif
-#if TCL_MAJOR_VERSION < 9
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/*
- * Exported function declarations:
- */
-
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
-/* 0 */
-EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
- Tcl_DString *dsPtr);
-/* 1 */
-EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
- Tcl_DString *dsPtr);
-/* Slot 2 is reserved */
-/* 3 */
-EXTERN void Tcl_WinConvertError(unsigned errCode);
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
-/* 0 */
-EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- const char *bundleName, int hasResourceFile,
- Tcl_Size maxPathLen, char *libraryPath);
-/* 1 */
-EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
- Tcl_Interp *interp, const char *bundleName,
- const char *bundleVersion,
- int hasResourceFile, Tcl_Size maxPathLen,
- char *libraryPath);
-/* 2 */
-EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
- const void *runLoopMode);
-#endif /* MACOSX */
-
-typedef struct TclPlatStubs {
- int magic;
- void *hooks;
-
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
- TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
- char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
- void (*reserved2)(void);
- void (*tcl_WinConvertError) (unsigned errCode); /* 3 */
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
- int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 0 */
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */
- void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */
-#endif /* MACOSX */
-} TclPlatStubs;
-
-extern const TclPlatStubs *tclPlatStubsPtr;
-
-#ifdef __cplusplus
-}
-#endif
-
-#if defined(USE_TCL_STUBS)
-
-/*
- * Inline function declarations:
- */
-
-#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
-#define Tcl_WinUtfToTChar \
- (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
-#define Tcl_WinTCharToUtf \
- (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
-/* Slot 2 is reserved */
-#define Tcl_WinConvertError \
- (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */
-#endif /* WIN */
-#ifdef MAC_OSX_TCL /* MACOSX */
-#define Tcl_MacOSXOpenBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
-#define Tcl_MacOSXOpenVersionedBundleResources \
- (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */
-#define Tcl_MacOSXNotifierAddRunLoopMode \
- (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */
-#endif /* MACOSX */
-
-#endif /* defined(USE_TCL_STUBS) */
-
-#else /* TCL_MAJOR_VERSION > 8 */
/* !BEGIN!: Do not edit below this line. */
#ifdef __cplusplus
extern "C" {
@@ -149,12 +73,12 @@
/* Slot 0 is reserved */
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
- int hasResourceFile, Tcl_Size maxPathLen,
- char *libraryPath);
+ Tcl_Size hasResourceFile,
+ Tcl_Size maxPathLen, char *libraryPath);
/* 2 */
EXTERN void Tcl_MacOSXNotifierAddRunLoopMode(
const void *runLoopMode);
/* 3 */
EXTERN void Tcl_WinConvertError(unsigned errCode);
@@ -162,11 +86,11 @@
typedef struct TclPlatStubs {
int magic;
void *hooks;
void (*reserved0)(void);
- int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */
+ 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;
@@ -190,13 +114,10 @@
(tclPlatStubsPtr->tcl_WinConvertError) /* 3 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
-
-#endif /* TCL_MAJOR_VERSION */
-
#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
@@ -211,12 +132,21 @@
#ifndef MAC_OSX_TCL
# undef Tcl_MacOSXOpenVersionedBundleResources
# undef Tcl_MacOSXNotifierAddRunLoopMode
#endif
-#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\
- && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)
+#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)))
Index: generic/tclPort.h
==================================================================
--- generic/tclPort.h
+++ generic/tclPort.h
@@ -1,16 +1,27 @@
+/*
+ * 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.
- *
- * 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.
*/
#ifndef _TCLPORT
#define _TCLPORT
Index: generic/tclPosixStr.c
==================================================================
--- generic/tclPosixStr.c
+++ generic/tclPosixStr.c
@@ -1,18 +1,29 @@
/*
- * tclPosixStr.c --
- *
- * This file contains procedures that generate strings corresponding to
- * various POSIX-related codes, such as errno and signals.
- *
* 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"
/*
*----------------------------------------------------------------------
*
Index: generic/tclPreserve.c
==================================================================
--- generic/tclPreserve.c
+++ generic/tclPreserve.c
@@ -1,19 +1,30 @@
/*
- * 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.
- *
* 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
Index: generic/tclProc.c
==================================================================
--- generic/tclProc.c
+++ generic/tclProc.c
@@ -1,20 +1,31 @@
/*
- * tclProc.c --
- *
- * This file contains routines that implement Tcl procedures, including
- * the "proc" and "uplevel" commands.
- *
* 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
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
/*
@@ -64,11 +75,11 @@
NULL, /* UpdateString function; Tcl_GetString and
* Tcl_GetStringFromObj should panic
* instead. */
NULL, /* SetFromAny function; Tcl_ConvertToType
* should panic instead. */
- TCL_OBJTYPE_V0
+ 0
};
#define ProcSetInternalRep(objPtr, procPtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -93,11 +104,11 @@
* rep; it's just a cache type.
*/
static const Tcl_ObjType levelReferenceType = {
"levelReference",
- NULL, NULL, NULL, NULL, TCL_OBJTYPE_V0
+ NULL, NULL, NULL, NULL, 0
};
/*
* The type of lambdas. Note that every lambda will *always* have a string
* representation.
@@ -111,11 +122,11 @@
"lambdaExpr", /* name */
FreeLambdaInternalRep, /* freeIntRepProc */
DupLambdaInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetLambdaFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -353,11 +364,11 @@
/*
* The argument list is just "args"; check the body
*/
- procBody = TclGetStringFromObj(objv[3], &numBytes);
+ procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
/*
@@ -448,11 +459,11 @@
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
Tcl_Size length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
- bytes = TclGetStringFromObj(bodyPtr, &length);
+ bytes = Tcl_GetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
* TIP #280.
* Ensure that the continuation line data for the original body is
@@ -538,11 +549,11 @@
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", (void *)NULL);
goto procError;
}
- argname = TclGetStringFromObj(fieldValues[0], &nameLength);
+ argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
@@ -601,12 +612,12 @@
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
Tcl_Size tmpLength, valueLength;
- const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength);
- const char *value = TclGetStringFromObj(fieldValues[1], &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);
@@ -2075,11 +2086,11 @@
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
- const char *procName = TclGetStringFromObj(procNameObj, &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,
@@ -2769,11 +2780,11 @@
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60;
Tcl_Size nameLen;
- const char *procName = TclGetStringFromObj(procNameObj, &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,
Index: generic/tclProcess.c
==================================================================
--- generic/tclProcess.c
+++ generic/tclProcess.c
@@ -1,17 +1,28 @@
/*
- * tclProcess.c --
- *
- * This file implements the "tcl::process" ensemble for subprocess
- * management as defined by TIP #462.
- *
* Copyright © 2017 Frederic Bonnet.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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).
Index: generic/tclRegexp.c
==================================================================
--- generic/tclRegexp.c
+++ generic/tclRegexp.c
@@ -1,18 +1,29 @@
/*
- * tclRegexp.c --
- *
- * This file contains the public interfaces to the Tcl regular expression
- * mechanism.
- *
* 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
@@ -106,11 +117,11 @@
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
#define RegexpSetInternalRep(objPtr, rePtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -599,11 +610,11 @@
const char *pattern;
RegexpGetInternalRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
- pattern = TclGetStringFromObj(objPtr, &length);
+ pattern = Tcl_GetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
Index: generic/tclRegexp.h
==================================================================
--- generic/tclRegexp.h
+++ generic/tclRegexp.h
@@ -1,18 +1,29 @@
/*
- * tclRegexp.h --
- *
- * This file contains definitions used internally by Henry Spencer's
- * regular expression code.
- *
* 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"
Index: generic/tclResolve.c
==================================================================
--- generic/tclResolve.c
+++ generic/tclResolve.c
@@ -1,17 +1,28 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
/*
Index: generic/tclResult.c
==================================================================
--- generic/tclResult.c
+++ generic/tclResult.c
@@ -1,16 +1,27 @@
/*
- * tclResult.c --
- *
- * This file contains code to manage the interpreter result.
- *
* 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
/*
* Indices of the standard return options dictionary keys.
@@ -357,11 +368,11 @@
Tcl_Size length;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
- bytes = TclGetStringFromObj(iPtr->objResultPtr, &length);
+ bytes = Tcl_GetStringFromObj(iPtr->objResultPtr, &length);
if (TclNeedSpace(bytes, bytes + length)) {
Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
@@ -718,11 +729,11 @@
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
Tcl_Size length;
- (void)TclGetStringFromObj(valuePtr, &length);
+ (void)Tcl_GetStringFromObj(valuePtr, &length);
if (length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
Index: generic/tclScan.c
==================================================================
--- generic/tclScan.c
+++ generic/tclScan.c
@@ -1,16 +1,27 @@
/*
- * tclScan.c --
- *
- * This file contains the implementation of the "scan" command.
- *
* 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
/*
@@ -1043,11 +1054,11 @@
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
- = TclFetchInternalRep(objPtr, &tclDoubleType);
+ = TclFetchInternalRep(objPtr, tclDoubleType);
if (irPtr) {
dvalue = irPtr->doubleValue;
} else
#endif
{
DELETED generic/tclStrIdxTree.c
Index: generic/tclStrIdxTree.c
==================================================================
--- generic/tclStrIdxTree.c
+++ /dev/null
@@ -1,558 +0,0 @@
-/*
- * 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
- *
- * Lists:
- *
- * {Januar Februar Maerz April Mai Juni Juli August September Oktober November Dezember}
- * {Jnr Fbr Mrz Apr Mai Jni Jli Agt Spt Okt Nvb Dzb}
- *
- * Index-Tree:
- *
- * j 0 * ...
- * anuar 1 *
- * u 0 * a 0
- * ni 6 * pril 4
- * li 7 * ugust 8
- * n 0 * gt 8
- * r 1 * s 9
- * i 6 * eptember 9
- * li 7 * pt 9
- * f 2 * oktober 10
- * ebruar 2 * n 11
- * br 2 * ovember 11
- * m 0 * vb 11
- * a 0 * d 12
- * erz 3 * ezember 12
- * i 5 * zb 12
- * rz 3 *
- * ...
- *
- * Thereby value 0 shows pure group items (corresponding ambigous matches).
- * But the group may have a value if it contains only same values
- * (see for example group "f" above).
- *
- * StrIdxTree's are very fast, so:
- * build of above-mentioned tree takes about 10 microseconds.
- * search of string index in this tree takes fewer as 0.1 microseconds.
- *
- */
-
-#include "tclInt.h"
-#include "tclStrIdxTree.h"
-
-static void StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static void StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr);
-static void StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr);
-
-static const Tcl_ObjType StrIdxTreeObjType = {
- "str-idx-tree", /* name */
- StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */
- StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */
- StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
- NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * TclStrIdxTreeSearch --
- *
- * Find largest part of string "start" in indexed tree (case sensitive).
- *
- * Also used for building of string index tree.
- *
- * Results:
- * Return position of UTF character in start after last equal character
- * and found item (with parent).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-const char *
-TclStrIdxTreeSearch(
- TclStrIdxTree **foundParent,/* Return value of found sub tree (used for tree build) */
- TclStrIdx **foundItem, /* Return value of found item */
- TclStrIdxTree *tree, /* Index tree will be browsed */
- const char *start, /* UTF string to find in tree */
- const char *end) /* End of string */
-{
- TclStrIdxTree *parent = tree, *prevParent = tree;
- TclStrIdx *item = tree->firstPtr, *prevItem = NULL;
- const char *s = start, *f, *cin, *cinf, *prevf = NULL;
- Tcl_Size offs = 0;
-
- if (item == NULL) {
- goto done;
- }
-
- /* search in tree */
- do {
- cinf = cin = TclGetString(item->key) + offs;
- f = TclUtfFindEqualNCInLwr(s, end, cin, cin + item->length - offs, &cinf);
- /* if something was found */
- if (f > s) {
- /* if whole string was found */
- if (f >= end) {
- start = f;
- goto done;
- }
-
- /* set new offset and shift start string */
- offs += cinf - cin;
- s = f;
-
- /* if match item, go deeper as long as possible */
- if (offs >= item->length && item->childTree.firstPtr) {
- /* save previuosly found item (if not ambigous) for
- * possible fallback (few greedy match) */
- if (item->value != NULL) {
- prevf = f;
- prevItem = item;
- prevParent = parent;
- }
- parent = &item->childTree;
- item = item->childTree.firstPtr;
- continue;
- }
-
- /* no children - return this item and current chars found */
- start = f;
- goto done;
- }
-
- item = item->nextPtr;
- } while (item != NULL);
-
- /* fallback (few greedy match) not ambigous (has a value) */
- if (prevItem != NULL) {
- item = prevItem;
- parent = prevParent;
- start = prevf;
- }
-
- done:
- if (foundParent) {
- *foundParent = parent;
- }
- if (foundItem) {
- *foundItem = item;
- }
- return start;
-}
-
-void
-TclStrIdxTreeFree(
- TclStrIdx *tree)
-{
- while (tree != NULL) {
- TclStrIdx *t = tree;
-
- Tcl_DecrRefCount(tree->key);
- if (tree->childTree.firstPtr != NULL) {
- TclStrIdxTreeFree(tree->childTree.firstPtr);
- }
- tree = tree->nextPtr;
- Tcl_Free(t);
- }
-}
-
-/*
- * Several bidirectional list primitives
- */
-
-static inline void
-TclStrIdxTreeInsertBranch(
- TclStrIdxTree *parent,
- TclStrIdx *item,
- TclStrIdx *child)
-{
- if (parent->firstPtr == child) {
- parent->firstPtr = item;
- }
- if (parent->lastPtr == child) {
- parent->lastPtr = item;
- }
- if ((item->nextPtr = child->nextPtr) != NULL) {
- item->nextPtr->prevPtr = item;
- child->nextPtr = NULL;
- }
- if ((item->prevPtr = child->prevPtr) != NULL) {
- item->prevPtr->nextPtr = item;
- child->prevPtr = NULL;
- }
- item->childTree.firstPtr = child;
- item->childTree.lastPtr = child;
-}
-
-static inline void
-TclStrIdxTreeAppend(
- TclStrIdxTree *parent,
- TclStrIdx *item)
-{
- if (parent->lastPtr != NULL) {
- parent->lastPtr->nextPtr = item;
- }
- item->prevPtr = parent->lastPtr;
- item->nextPtr = NULL;
- parent->lastPtr = item;
- if (parent->firstPtr == NULL) {
- parent->firstPtr = item;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclStrIdxTreeBuildFromList --
- *
- * Build or extend string indexed tree from tcl list. If the values not
- * given the values of built list are indices starts with 1. Value of 0
- * is thereby reserved to the ambigous values.
- *
- * Important: by multiple lists, optimal tree can be created only if list
- * with larger strings used firstly.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-int
-TclStrIdxTreeBuildFromList(
- TclStrIdxTree *idxTree,
- Tcl_Size lstc,
- Tcl_Obj **lstv,
- void **values)
-{
- Tcl_Obj **lwrv;
- Tcl_Size i;
- int ret = TCL_ERROR;
- void *val;
- const char *s, *e, *f;
- TclStrIdx *item;
-
- /* create lowercase reflection of the list keys */
-
- lwrv = (Tcl_Obj **) Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc);
- if (lwrv == NULL) {
- return TCL_ERROR;
- }
- for (i = 0; i < lstc; i++) {
- lwrv[i] = Tcl_DuplicateObj(lstv[i]);
- Tcl_IncrRefCount(lwrv[i]);
- lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i]));
- }
-
- /* build index tree of the list keys */
- for (i = 0; i < lstc; i++) {
- TclStrIdxTree *foundParent = idxTree;
-
- e = s = TclGetString(lwrv[i]);
- e += lwrv[i]->length;
- val = values ? values[i] : INT2PTR(i+1);
-
- /* ignore empty keys (impossible to index it) */
- if (lwrv[i]->length == 0) {
- continue;
- }
-
- item = NULL;
- if (idxTree->firstPtr != NULL) {
- TclStrIdx *foundItem;
-
- f = TclStrIdxTreeSearch(&foundParent, &foundItem, idxTree, s, e);
- /* if common prefix was found */
- if (f > s) {
- /* ignore element if fulfilled or ambigous */
- if (f == e) {
- continue;
- }
-
- /* if shortest key was found with the same value,
- * just replace its current key with longest key */
- if (foundItem->value == val
- && foundItem->length <= lwrv[i]->length
- && foundItem->length <= (f - s) // only if found item is covered in full
- && foundItem->childTree.firstPtr == NULL) {
- TclSetObjRef(foundItem->key, lwrv[i]);
- foundItem->length = lwrv[i]->length;
- continue;
- }
-
- /* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) )
- * but don't split by fulfilled child of found item ( ii->iii->iiii ) */
- if (foundItem->length != (f - s)) {
- /* first split found item (insert one between parent and found + new one) */
- item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx));
- if (item == NULL) {
- goto done;
- }
- TclInitObjRef(item->key, foundItem->key);
- item->length = f - s;
-
- /* set value or mark as ambigous if not the same value of both */
- item->value = (foundItem->value == val) ? val : NULL;
-
- /* insert group item between foundParent and foundItem */
- TclStrIdxTreeInsertBranch(foundParent, item, foundItem);
- foundParent = &item->childTree;
- } else {
- /* the new item should be added as child of found item */
- foundParent = &foundItem->childTree;
- }
- }
- }
-
- /* append item at end of found parent */
- item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx));
- if (item == NULL) {
- goto done;
- }
- item->childTree.lastPtr = item->childTree.firstPtr = NULL;
- TclInitObjRef(item->key, lwrv[i]);
- item->length = lwrv[i]->length;
- item->value = val;
- TclStrIdxTreeAppend(foundParent, item);
- }
-
- ret = TCL_OK;
- done:
- if (lwrv != NULL) {
- for (i = 0; i < lstc; i++) {
- Tcl_DecrRefCount(lwrv[i]);
- }
- Tcl_Free(lwrv);
- }
- if (ret != TCL_OK) {
- if (idxTree->firstPtr != NULL) {
- TclStrIdxTreeFree(idxTree->firstPtr);
- }
- }
- return ret;
-}
-
-/* Is a Tcl_Obj (of right type) holding a smart pointer link? */
-static inline int
-IsLink(
- Tcl_Obj *objPtr)
-{
- Tcl_ObjInternalRep *irPtr = &objPtr->internalRep;
- return irPtr->twoPtrValue.ptr1 && !irPtr->twoPtrValue.ptr2;
-}
-
-/* Follow links (smart pointers) if present. */
-static inline Tcl_Obj *
-FollowPossibleLink(
- Tcl_Obj *objPtr)
-{
- if (IsLink(objPtr)) {
- objPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
- }
- /* assert(!IsLink(objPtr)); */
- return objPtr;
-}
-
-Tcl_Obj *
-TclStrIdxTreeNewObj(void)
-{
- Tcl_Obj *objPtr = Tcl_NewObj();
- TclStrIdxTree *tree = (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
-
- /*
- * This assert states that we can safely directly have a tree node as the
- * internal representation of a Tcl_Obj instead of needing to hang it
- * off the back with an extra alloc.
- */
- TCL_CT_ASSERT(sizeof(TclStrIdxTree) <= sizeof(Tcl_ObjInternalRep));
-
- tree->firstPtr = NULL;
- tree->lastPtr = NULL;
- objPtr->typePtr = &StrIdxTreeObjType;
- /* return tree root in internal representation */
- return objPtr;
-}
-
-static void
-StrIdxTreeObj_DupIntRepProc(
- Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr)
-{
- /* follow links (smart pointers) */
- srcPtr = FollowPossibleLink(srcPtr);
-
- /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */
- TclInitObjRef(*((Tcl_Obj **) ©Ptr->internalRep.twoPtrValue.ptr1),
- srcPtr);
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- copyPtr->typePtr = &StrIdxTreeObjType;
-}
-
-static void
-StrIdxTreeObj_FreeIntRepProc(
- Tcl_Obj *objPtr)
-{
- /* follow links (smart pointers) */
- if (IsLink(objPtr)) {
- /* is a link */
- TclUnsetObjRef(*((Tcl_Obj **) &objPtr->internalRep.twoPtrValue.ptr1));
- } else {
- /* is a tree */
- TclStrIdxTree *tree = (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
-
- if (tree->firstPtr != NULL) {
- TclStrIdxTreeFree(tree->firstPtr);
- }
- tree->firstPtr = NULL;
- tree->lastPtr = NULL;
- }
- objPtr->typePtr = NULL;
-}
-
-static void
-StrIdxTreeObj_UpdateStringProc(
- Tcl_Obj *objPtr)
-{
- /* currently only dummy empty string possible */
- objPtr->length = 0;
- objPtr->bytes = &tclEmptyString;
-}
-
-TclStrIdxTree *
-TclStrIdxTreeGetFromObj(
- Tcl_Obj *objPtr)
-{
- if (objPtr->typePtr != &StrIdxTreeObjType) {
- return NULL;
- }
-
- /* follow links (smart pointers) */
- objPtr = FollowPossibleLink(objPtr);
-
- /* return tree root in internal representation */
- return (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue;
-}
-
-/*
- * Several debug primitives
- */
-#ifdef TEST_STR_IDX_TREE
-/* currently unused, debug resp. test purposes only */
-
-static void
-TclStrIdxTreePrint(
- Tcl_Interp *interp,
- TclStrIdx *tree,
- int offs)
-{
- Tcl_Obj *obj[2];
- const char *s;
-
- TclInitObjRef(obj[0], Tcl_NewStringObj("::puts", TCL_AUTO_LENGTH));
- while (tree != NULL) {
- s = TclGetString(tree->key) + offs;
- TclInitObjRef(obj[1], Tcl_ObjPrintf("%*s%.*s\t:%d",
- offs, "", tree->length - offs, s, tree->value));
- Tcl_PutsObjCmd(NULL, interp, 2, obj);
- TclUnsetObjRef(obj[1]);
- if (tree->childTree.firstPtr != NULL) {
- TclStrIdxTreePrint(interp, tree->childTree.firstPtr, tree->length);
- }
- tree = tree->nextPtr;
- }
- TclUnsetObjRef(obj[0]);
-}
-
-int
-TclStrIdxTreeTestObjCmd(
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[])
-{
- const char *cs, *cin, *ret;
- static const char *const options[] = {
- "index", "puts-index", "findequal",
- NULL
- };
- enum optionInd {
- O_INDEX, O_PUTS_INDEX, O_FINDEQUAL
- };
- int optionIndex;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], options,
- "option", 0, &optionIndex) != TCL_OK) {
- Tcl_SetErrorCode(interp, "CLOCK", "badOption",
- TclGetString(objv[1]), (char *)NULL);
- return TCL_ERROR;
- }
-
- switch (optionIndex) {
- case O_FINDEQUAL:
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "");
- return TCL_ERROR;
- }
- cs = TclGetString(objv[2]);
- cin = TclGetString(objv[3]);
- ret = TclUtfFindEqual(
- cs, cs + objv[1]->length, cin, cin + objv[2]->length);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs));
- break;
-
- case O_INDEX:
- case O_PUTS_INDEX: {
- Tcl_Obj **lstv;
- Tcl_Size i, lstc;
- TclStrIdxTree idxTree = {NULL, NULL};
-
- i = 1;
- while (++i < objc) {
- if (TclListObjGetElements(interp, objv[i],
- &lstc, &lstv) != TCL_OK) {
- return TCL_ERROR;
- }
- TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv, NULL);
- }
- if (optionIndex == O_PUTS_INDEX) {
- TclStrIdxTreePrint(interp, idxTree.firstPtr, 0);
- }
- TclStrIdxTreeFree(idxTree.firstPtr);
- break;
- }
- }
-
- return TCL_OK;
-}
-#endif
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
DELETED generic/tclStrIdxTree.h
Index: generic/tclStrIdxTree.h
==================================================================
--- generic/tclStrIdxTree.h
+++ /dev/null
@@ -1,189 +0,0 @@
-/*
- * tclStrIdxTree.h --
- *
- * Declarations of string index tries and other primitives currently
- * back-ported from tclSE.
- *
- * Copyright (c) 2016 Serg G. Brester (aka sebres)
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef _TCLSTRIDXTREE_H
-#define _TCLSTRIDXTREE_H
-
-#include "tclInt.h"
-
-/*
- * Main structures declarations of index tree and entry
- */
-
-typedef struct TclStrIdx TclStrIdx;
-
-/*
- * Top level structure of the tree, or first two fields of the interior
- * structure.
- *
- * Note that this is EXACTLY two pointers so it is the same size as the
- * twoPtrValue of a Tcl_ObjInternalRep. This is how the top level structure
- * of the tree is always allocated. (This type constraint is asserted in
- * TclStrIdxTreeNewObj() so it's guaranteed.)
- *
- * Also note that if firstPtr is not NULL, lastPtr must also be not NULL.
- * The case where firstPtr is not NULL and lastPtr is NULL is special (a
- * smart pointer to one of these) and is not actually a valid instance of
- * this structure.
- */
-typedef struct TclStrIdxTree {
- TclStrIdx *firstPtr;
- TclStrIdx *lastPtr;
-} TclStrIdxTree;
-
-/*
- * An interior node of the tree. Always directly allocated.
- */
-struct TclStrIdx {
- TclStrIdxTree childTree;
- TclStrIdx *nextPtr;
- TclStrIdx *prevPtr;
- Tcl_Obj *key;
- Tcl_Size length;
- void *value;
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * TclUtfFindEqual, TclUtfFindEqualNC --
- *
- * Find largest part of string cs in string cin (case sensitive and not).
- *
- * Results:
- * Return position of UTF character in cs after last equal character.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static inline const char *
-TclUtfFindEqual(
- const char *cs, /* UTF string to find in cin. */
- const char *cse, /* End of cs */
- const char *cin, /* UTF string will be browsed. */
- const char *cine) /* End of cin */
-{
- const char *ret = cs;
- Tcl_UniChar ch1, ch2;
-
- do {
- cs += TclUtfToUniChar(cs, &ch1);
- cin += TclUtfToUniChar(cin, &ch2);
- if (ch1 != ch2) {
- break;
- }
- } while ((ret = cs) < cse && cin < cine);
- return ret;
-}
-
-static inline const char *
-TclUtfFindEqualNC(
- const char *cs, /* UTF string to find in cin. */
- const char *cse, /* End of cs */
- const char *cin, /* UTF string will be browsed. */
- const char *cine, /* End of cin */
- const char **cinfnd) /* Return position in cin */
-{
- const char *ret = cs;
- Tcl_UniChar ch1, ch2;
-
- do {
- cs += TclUtfToUniChar(cs, &ch1);
- cin += TclUtfToUniChar(cin, &ch2);
- if (ch1 != ch2) {
- ch1 = Tcl_UniCharToLower(ch1);
- ch2 = Tcl_UniCharToLower(ch2);
- if (ch1 != ch2) {
- break;
- }
- }
- *cinfnd = cin;
- } while ((ret = cs) < cse && cin < cine);
- return ret;
-}
-
-static inline const char *
-TclUtfFindEqualNCInLwr(
- const char *cs, /* UTF string (in anycase) to find in cin. */
- const char *cse, /* End of cs */
- const char *cin, /* UTF string (in lowercase) will be browsed. */
- const char *cine, /* End of cin */
- const char **cinfnd) /* Return position in cin */
-{
- const char *ret = cs;
- Tcl_UniChar ch1, ch2;
-
- do {
- cs += TclUtfToUniChar(cs, &ch1);
- cin += TclUtfToUniChar(cin, &ch2);
- if (ch1 != ch2) {
- ch1 = Tcl_UniCharToLower(ch1);
- if (ch1 != ch2) {
- break;
- }
- }
- *cinfnd = cin;
- } while ((ret = cs) < cse && cin < cine);
- return ret;
-}
-
-/*
- * Primitives to safe set, reset and free references.
- */
-
-#define TclUnsetObjRef(obj) \
- do { \
- if (obj != NULL) { \
- Tcl_DecrRefCount(obj); \
- obj = NULL; \
- } \
- } while (0)
-#define TclInitObjRef(obj, val) \
- do { \
- obj = (val); \
- if (obj) { \
- Tcl_IncrRefCount(obj); \
- } \
- } while (0)
-#define TclSetObjRef(obj, val) \
- do { \
- Tcl_Obj *nval = (val); \
- if (obj != nval) { \
- Tcl_Obj *prev = obj; \
- TclInitObjRef(obj, nval); \
- if (prev != NULL) { \
- Tcl_DecrRefCount(prev); \
- } \
- } \
- } while (0)
-
-/*
- * Prototypes of module functions.
- */
-
-MODULE_SCOPE const char*TclStrIdxTreeSearch(TclStrIdxTree **foundParent,
- TclStrIdx **foundItem, TclStrIdxTree *tree,
- const char *start, const char *end);
-MODULE_SCOPE int TclStrIdxTreeBuildFromList(TclStrIdxTree *idxTree,
- Tcl_Size lstc, Tcl_Obj **lstv, void **values);
-MODULE_SCOPE Tcl_Obj * TclStrIdxTreeNewObj(void);
-MODULE_SCOPE TclStrIdxTree*TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr);
-
-#ifdef TEST_STR_IDX_TREE
-/* currently unused, debug resp. test purposes only */
-MODULE_SCOPE Tcl_ObjCmdProc TclStrIdxTreeTestObjCmd;
-#endif
-
-#endif /* _TCLSTRIDXTREE_H */
Index: generic/tclStrToD.c
==================================================================
--- generic/tclStrToD.c
+++ generic/tclStrToD.c
@@ -1,18 +1,29 @@
+/*
+ * 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.
- *
- * Copyright © 2005 Kevin B. Kenny. All rights reserved.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include
@@ -546,15 +557,15 @@
* didn't pass anything else.
*/
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
- if (TclHasInternalRep(objPtr, &tclDictType)) {
+ if (TclHasInternalRep(objPtr, tclDictTypePtr)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
- if (TclHasInternalRep(objPtr, &tclListType)) {
+ 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;
@@ -1382,11 +1393,11 @@
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
- objPtr->typePtr = &tclIntType;
+ objPtr->typePtr = tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-octalSignificandWide);
} else {
objPtr->internalRep.wideValue =
@@ -1418,11 +1429,11 @@
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
- objPtr->typePtr = &tclIntType;
+ objPtr->typePtr = tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-significandWide);
} else {
objPtr->internalRep.wideValue =
@@ -1450,11 +1461,11 @@
* to whether 'significandOverflow' is set. The desired floating
* point value is significand * 10**k, where
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
- objPtr->typePtr = &tclDoubleType;
+ objPtr->typePtr = tclDoubleType;
if (exponentSignum) {
/*
* At this point exponent>=0, so the following calculation
* cannot underflow.
*/
@@ -1501,18 +1512,18 @@
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
- objPtr->typePtr = &tclDoubleType;
+ objPtr->typePtr = tclDoubleType;
break;
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
- objPtr->typePtr = &tclDoubleType;
+ objPtr->typePtr = tclDoubleType;
break;
#endif
case INITIAL:
/* This case only to silence compiler warning. */
Tcl_Panic("TclParseNumber: state INITIAL can't happen here");
Index: generic/tclStringObj.c
==================================================================
--- generic/tclStringObj.c
+++ generic/tclStringObj.c
@@ -1,5 +1,22 @@
+/*
+ * 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.
@@ -22,16 +39,10 @@
*
* 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.
- *
- * Copyright © 1995-1997 Sun Microsystems, Inc.
- * Copyright © 1999 Scriptics Corporation.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include "tclStringRep.h"
@@ -57,21 +68,20 @@
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);
-#define ISCONTINUATION(bytes) (\
- ((bytes)[0] & 0xC0) == 0x80)
-
/*
* The structure below defines the string Tcl object type by means of
* functions that can be invoked by generic object code.
*/
@@ -79,11 +89,11 @@
"string", /* name */
FreeStringInternalRep, /* freeIntRepPro */
DupStringInternalRep, /* dupIntRepProc */
UpdateStringOfString, /* updateStringProc */
SetStringFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
/*
* TCL STRING GROWTH ALGORITHM
*
@@ -367,15 +377,33 @@
* 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;
/*
@@ -382,11 +410,12 @@
* Quick, no-shimmer return for short string reps.
*/
if ((objPtr->bytes) && (objPtr->length < 2)) {
/* 0 bytes -> 0 chars; 1 byte -> 1 char */
- return objPtr->length;
+ *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.
@@ -398,11 +427,12 @@
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
(void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars);
- return numChars;
+ *length = numChars;
+ return TCL_OK;
}
/*
* OK, need to work with the object as a string.
*/
@@ -417,11 +447,12 @@
if (numChars < 0) {
TclNumUtfCharsM(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
}
- return numChars;
+ *length = numChars;
+ return TCL_OK;
}
Tcl_Size
TclGetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
@@ -475,37 +506,61 @@
*
*----------------------------------------------------------------------
*/
int
TclCheckEmptyString(
- Tcl_Obj *objPtr)
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int *res
+)
{
- Tcl_Size length = TCL_INDEX_NONE;
+ int status;
+ Tcl_Size length = 0;
if (objPtr->bytes == &tclEmptyString) {
- return TCL_EMPTYSTRING_YES;
+ *res = TCL_EMPTYSTRING_YES;
+ return TCL_OK;
}
if (TclIsPureByteArray(objPtr)
&& Tcl_GetCharLength(objPtr) == 0) {
- return TCL_EMPTYSTRING_YES;
+ *res = TCL_EMPTYSTRING_YES;
+ return TCL_OK;
}
if (TclListObjIsCanonical(objPtr)) {
- TclListObjLength(NULL, objPtr, &length);
- return length == 0;
+ status = TclListObjLength(interp, objPtr, &length);
+ if (status) {
+ return status;
+ } else {
+ *res = length == 0;
+ return TCL_OK;
+ }
}
if (TclIsPureDict(objPtr)) {
- Tcl_DictObjSize(NULL, objPtr, &length);
- return length == 0;
+ status = Tcl_DictObjSize(interp, objPtr, &length);
+ if (status) {
+ return status;
+ } else {
+ *res = length == 0;
+ return TCL_OK;
+ }
}
if (objPtr->bytes == NULL) {
- return TCL_EMPTYSTRING_UNKNOWN;
+ if (TclObjectHasInterface(objPtr, string, isEmpty)) {
+ TclObjectDispatchNoDefault(interp ,status ,objPtr ,string
+ ,isEmpty ,interp ,objPtr ,res);
+ return status;
+ } else {
+ *res = TCL_EMPTYSTRING_UNKNOWN;
+ return TCL_OK;
+ }
}
- return objPtr->length == 0;
+ *res = objPtr->length == 0;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -639,40 +694,10 @@
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetUnicodeFromObj
-#if !defined(TCL_NO_DEPRECATED)
-Tcl_UniChar *
-TclGetUnicodeFromObj(
- Tcl_Obj *objPtr, /* The object to find the Unicode string
- * for. */
- void *lengthPtr) /* If non-NULL, the location where the string
- * rep's Tcl_UniChar length should be stored. If
- * NULL, no length is stored. */
-{
- String *stringPtr;
-
- SetStringFromAny(NULL, objPtr);
- stringPtr = GET_STRING(objPtr);
-
- if (stringPtr->hasUnicode == 0) {
- FillUnicodeRep(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
-
- if (lengthPtr != NULL) {
- if (stringPtr->numChars > INT_MAX) {
- Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr"
- " cannot handle such long strings. Please use 'Tcl_Size'");
- }
- *(int *)lengthPtr = (int)stringPtr->numChars;
- }
- return stringPtr->unicode;
-}
-#endif /* !defined(TCL_NO_DEPRECATED) */
-
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
@@ -715,14 +740,23 @@
*----------------------------------------------------------------------
*/
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 *objPtr,
+ Tcl_Size first,
+ Tcl_Size last)
{
+ 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) {
@@ -740,13 +774,15 @@
if (last < 0 || last >= length) {
last = length - 1;
}
if (last < first) {
TclNewObj(newObjPtr);
- return newObjPtr;
+ *resPtrPtr = newObjPtr;
+ return TCL_OK;
}
- return Tcl_NewByteArrayObj(bytes + first, last - first + 1);
+ *resPtrPtr = Tcl_NewByteArrayObj(bytes + first, last - first + 1);
+ return TCL_OK;
}
/*
* OK, need to work with the object as a string.
*/
@@ -758,44 +794,52 @@
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == TCL_INDEX_NONE) {
- TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length);
+ 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);
- return newObjPtr;
+ *resPtrPtr = newObjPtr;
+ return TCL_OK;
}
- newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last - first + 1);
+ 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;
- return newObjPtr;
+ *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);
- return newObjPtr;
+ *resPtrPtr = newObjPtr;
+ return TCL_OK;
}
- return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
+ *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. */
@@ -1244,16 +1288,10 @@
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- /* If appended string starts with a continuation byte or a lower surrogate,
- * force objPtr to unicode representation. See [7f1162a867] */
- if (bytes && ISCONTINUATION(bytes)) {
- Tcl_GetUnicode(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
if (stringPtr->hasUnicode && (stringPtr->numChars > 0)) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
}
@@ -1377,16 +1415,27 @@
{
String *stringPtr;
Tcl_Size length = 0, numChars;
Tcl_Size appendNumChars = TCL_INDEX_NONE;
const char *bytes;
+ int isEmpty, status;
- if (TclCheckEmptyString(appendObjPtr) == TCL_EMPTYSTRING_YES) {
+ 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;
}
- if (TclCheckEmptyString(objPtr) == TCL_EMPTYSTRING_YES) {
+ 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)
@@ -1447,17 +1496,10 @@
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
- /* If appended string starts with a continuation byte or a lower surrogate,
- * force objPtr to unicode representation. See [7f1162a867]
- * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */
- if (ISCONTINUATION(TclGetString(appendObjPtr))) {
- Tcl_GetUnicode(objPtr);
- stringPtr = GET_STRING(objPtr);
- }
/*
* If objPtr has a valid Unicode rep, then get a Unicode string from
* appendObjPtr and append it.
*/
@@ -1470,11 +1512,11 @@
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
- bytes = TclGetStringFromObj(appendObjPtr, &length);
+ bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
@@ -1482,11 +1524,11 @@
* 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 = TclGetStringFromObj(appendObjPtr, &length);
+ bytes = Tcl_GetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
@@ -1861,11 +1903,11 @@
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)TclGetStringFromObj(appendObj, &originalLength);
+ (void)Tcl_GetStringFromObj(appendObj, &originalLength);
limit = TCL_SIZE_MAX - originalLength;
/*
* Format string is NUL-terminated.
*/
@@ -2289,11 +2331,11 @@
pure = Tcl_NewBignumObj(&big);
} else {
TclNewIntObj(pure, l);
}
Tcl_IncrRefCount(pure);
- bytes = TclGetStringFromObj(pure, &length);
+ bytes = Tcl_GetStringFromObj(pure, &length);
/*
* Already did the sign above.
*/
@@ -2575,11 +2617,11 @@
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
- (void)TclGetStringFromObj(segment, &segmentNumBytes);
+ (void)Tcl_GetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
@@ -2958,11 +3000,11 @@
Tcl_Size *sizePtr)
{
String *stringPtr;
if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
- return TclGetStringFromObj(objPtr, sizePtr);
+ return Tcl_GetStringFromObj(objPtr, sizePtr);
}
stringPtr = GET_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
@@ -3024,11 +3066,11 @@
/* 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)TclGetStringFromObj(objPtr, &length);
+ (void)Tcl_GetStringFromObj(objPtr, &length);
maxCount = TCL_SIZE_MAX;
}
if (length == 0) {
/* Any repeats of empty is empty. */
@@ -3150,11 +3192,11 @@
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
int binary = 1;
Tcl_Size oc, length = 0;
- int allowUniChar = 1, requestUniChar = 0, forceUniChar = 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) {
@@ -3188,13 +3230,13 @@
* Non-empty string rep. Not a pure bytearray, so we won't
* create a pure bytearray.
*/
binary = 0;
- if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) {
- forceUniChar = 1;
- } else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) {
+ if ((objPtr->typePtr)
+ && !TclHasInternalRep(
+ objPtr, &tclStringType)) {
/* Prevent shimmer of non-string types. */
allowUniChar = 0;
}
}
} else {
@@ -3239,11 +3281,11 @@
}
length += numBytes;
}
}
} while (--oc);
- } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ } else if ((allowUniChar && requestUniChar)) {
/*
* Result will be pure Tcl_UniChar array. Pre-size it.
*/
ov = objv;
@@ -3277,18 +3319,22 @@
* Loop until a possibly non-empty value is reached.
* Keep string rep generation pending when possible.
*/
do {
+ int isEmpty, status;
Tcl_Obj *objPtr = *ov++;
- if (objPtr->bytes == NULL
- && TclCheckEmptyString(objPtr) != TCL_EMPTYSTRING_YES) {
+ 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) TclGetStringFromObj(objPtr, &length); /* PANIC? */
+ (void) Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
}
} while (--oc && (length == 0) && (pendingPtr == NULL));
/*
* Either we found a possibly non-empty value, and we remember
@@ -3308,18 +3354,18 @@
* is found, or the pending value gets its string generated.
*/
do {
Tcl_Obj *objPtr = *ov++;
- (void)TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ (void)Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
} while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
if (numBytes) {
last = objc -oc -1;
}
if (oc || numBytes) {
- (void)TclGetStringFromObj(pendingPtr, &length);
+ (void)Tcl_GetStringFromObj(pendingPtr, &length);
}
if (length == 0) {
if (numBytes) {
first = last;
}
@@ -3389,11 +3435,11 @@
unsigned char *src = Tcl_GetBytesFromObj(NULL, objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
- } else if ((allowUniChar && requestUniChar) || forceUniChar) {
+ } else if ((allowUniChar && requestUniChar)) {
/* Efficiently produce a pure Tcl_UniChar array result */
Tcl_UniChar *dst;
if (inPlace) {
Tcl_Size start;
@@ -3449,11 +3495,11 @@
if (inPlace) {
Tcl_Size start;
objResultPtr = *objv++; objc--;
- (void)TclGetStringFromObj(objResultPtr, &start);
+ (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));
@@ -3481,11 +3527,11 @@
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
Tcl_Size more;
- char *src = TclGetStringFromObj(objPtr, &more);
+ char *src = Tcl_GetStringFromObj(objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
@@ -3638,11 +3684,11 @@
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, match;
+ int empty, empty2, match, status;
Tcl_Size length, s1len = 0, s2len = 0;
memCmpFn_t memCmpFn;
if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
/*
@@ -3709,32 +3755,41 @@
memCmpFn = UniCharNmemcmp;
}
}
}
} else {
- empty = TclCheckEmptyString(value1Ptr);
+ 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 (TclCheckEmptyString(value2Ptr)) {
+ switch (empty2) {
case -1:
s1 = "";
s1len = 0;
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ 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 (TclCheckEmptyString(value2Ptr) > 0) {
+ } else if (empty2 > 0) {
switch (empty) {
case -1:
s2 = "";
s2len = 0;
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
+ s1 = Tcl_GetStringFromObj(value1Ptr, &s1len);
break;
case 0:
match = 1;
goto matchdone;
case 1:
@@ -3741,12 +3796,12 @@
default: /* avoid warn: `s1` may be used uninitialized */
match = 0;
goto matchdone;
}
} else {
- s1 = TclGetStringFromObj(value1Ptr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
+ 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
@@ -3912,10 +3967,36 @@
}
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 --
Index: generic/tclStringRep.h
==================================================================
--- generic/tclStringRep.h
+++ generic/tclStringRep.h
@@ -1,20 +1,31 @@
+/*
+ * 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.
- *
- * 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.
*/
#ifndef _TCLSTRINGREP
#define _TCLSTRINGREP
Index: generic/tclStringTrim.h
==================================================================
--- generic/tclStringTrim.h
+++ generic/tclStringTrim.h
@@ -1,12 +1,6 @@
/*
- * 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.
- *
* 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.
@@ -13,10 +7,27 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
Index: generic/tclStubCall.c
==================================================================
--- generic/tclStubCall.c
+++ generic/tclStubCall.c
@@ -1,12 +1,23 @@
/*
- * tclStubCall.c --
- *
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
#else
# define dlopen(a,b) (void *)LoadLibraryW(JOIN(L,a))
Index: generic/tclStubInit.c
==================================================================
--- generic/tclStubInit.c
+++ generic/tclStubInit.c
@@ -1,16 +1,27 @@
/*
- * tclStubInit.c --
- *
- * This file contains the initializers for the Tcl stub vectors.
- *
* Copyright © 1998-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__
@@ -60,23 +71,27 @@
#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 TclGetStringFromObj
-#if defined(TCL_NO_DEPRECATED)
-# define TclGetStringFromObj 0
+# undef TclGetBytesFromObj
+# undef TclGetUnicodeFromObj
# define TclGetBytesFromObj 0
# define TclGetUnicodeFromObj 0
-#endif
#undef Tcl_Close
#define Tcl_Close 0
#undef Tcl_GetByteArrayFromObj
#define Tcl_GetByteArrayFromObj 0
#define TclUnusedStubEntry 0
@@ -84,130 +99,18 @@
#define TclUtfNext Tcl_UtfNext
#define TclUtfPrev Tcl_UtfPrev
#undef TclListObjGetElements
#undef TclListObjLength
-#if defined(TCL_NO_DEPRECATED)
# define TclListObjGetElements 0
# define TclListObjLength 0
# define TclDictObjSize 0
# define TclSplitList 0
# define TclSplitPath 0
# define TclFSSplitPath 0
# define TclParseArgsObjv 0
# define TclGetAliasObj 0
-#else /* !defined(TCL_NO_DEPRECATED) */
-int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
- void *objcPtr, Tcl_Obj ***objvPtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr);
- if (objcPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
- if (interp) {
- Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL);
- }
- return TCL_ERROR;
- }
- *(int *)objcPtr = (int)n;
- }
- return result;
-}
-int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
- void *lengthPtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- int result = Tcl_ListObjLength(interp, listPtr, &n);
- if (lengthPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
- if (interp) {
- Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL);
- }
- return TCL_ERROR;
- }
- *(int *)lengthPtr = (int)n;
- }
- return result;
-}
-int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr,
- void *sizePtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- int result = Tcl_DictObjSize(interp, dictPtr, &n);
- if (sizePtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
- if (interp) {
- Tcl_AppendResult(interp, "Dict too large to be processed", (void *)NULL);
- }
- return TCL_ERROR;
- }
- *(int *)sizePtr = (int)n;
- }
- return result;
-}
-int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr,
- const char ***argvPtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- int result = Tcl_SplitList(interp, listStr, &n, argvPtr);
- if (argcPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
- if (interp) {
- Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL);
- }
- Tcl_Free((void *)*argvPtr);
- return TCL_ERROR;
- }
- *(int *)argcPtr = (int)n;
- }
- return result;
-}
-void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- Tcl_SplitPath(path, &n, argvPtr);
- if (argcPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (n > INT_MAX)) {
- n = TCL_INDEX_NONE; /* No other way to return an error-situation */
- Tcl_Free((void *)*argvPtr);
- *argvPtr = NULL;
- }
- *(int *)argcPtr = (int)n;
- }
-}
-Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) {
- Tcl_Size n = TCL_INDEX_NONE;
- Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n);
- if (lenPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && result && (n > INT_MAX)) {
- Tcl_DecrRefCount(result);
- return NULL;
- }
- *(int *)lenPtr = (int)n;
- }
- return result;
-}
-int TclParseArgsObjv(Tcl_Interp *interp,
- const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv,
- Tcl_Obj ***remObjv) {
- Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ;
- int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv);
- *(int *)objcPtr = (int)n;
- return result;
-}
-int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd,
- Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
- int *objcPtr, Tcl_Obj ***objv) {
- Tcl_Size n = TCL_INDEX_NONE;
- int result = Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, objv);
- if (objcPtr) {
- if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) {
- if (interp) {
- Tcl_AppendResult(interp, "List too large to be processed", NULL);
- }
- return TCL_ERROR;
- }
- *objcPtr = (int)n;
- }
- return result;
-}
-#endif /* !defined(TCL_NO_DEPRECATED) */
#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
@@ -858,17 +761,17 @@
0, /* 36 */
Tcl_GetInt, /* 37 */
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
- TclGetStringFromObj, /* 41 */
+ 0, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
- TclListObjGetElements, /* 45 */
+ 0, /* 45 */
Tcl_ListObjIndex, /* 46 */
- TclListObjLength, /* 47 */
+ 0, /* 47 */
Tcl_ListObjReplace, /* 48 */
0, /* 49 */
Tcl_NewByteArrayObj, /* 50 */
Tcl_NewDoubleObj, /* 51 */
0, /* 52 */
@@ -1508,8 +1411,39 @@
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. */
Index: generic/tclStubLib.c
==================================================================
--- generic/tclStubLib.c
+++ generic/tclStubLib.c
@@ -1,18 +1,29 @@
/*
- * tclStubLib.c --
- *
- * Stub object that will be statically linked into extensions that want
- * to access Tcl.
- *
* 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;
Index: generic/tclStubLibTbl.c
==================================================================
--- generic/tclStubLibTbl.c
+++ generic/tclStubLibTbl.c
@@ -1,18 +1,29 @@
/*
- * tclStubLibTbl.c --
- *
- * Stub object that will be statically linked into extensions that want
- * to access Tcl.
- *
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 1998 Paul Duffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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;
/*
Index: generic/tclTest.c
==================================================================
--- generic/tclTest.c
+++ generic/tclTest.c
@@ -1,30 +1,41 @@
/*
- * 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.
- *
* 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.
*/
-#define TCL_8_API
-#undef BUILD_tcl
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
-#ifndef USE_TCL_STUBS
+# undef BUILD_tcl
+# ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
-#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */
#include "tclInt.h"
+#undef TCLBOOLWARNING
+#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */
#include "tclOO.h"
#include
/*
* Required for Testregexp*Cmd
@@ -508,13 +519,10 @@
".purify"
#endif
#ifdef STATIC_BUILD
".static"
#endif
-#if TCL_UTF_MAX < 4
- ".utf-16"
-#endif
;
int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
@@ -534,16 +542,14 @@
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
-#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
-#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
@@ -718,10 +724,16 @@
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
@@ -801,16 +813,14 @@
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
-#if TCL_MAJOR_VERSION > 8
if (info.isNativeObjectProc == 2) {
Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
info.objProc2, (void *)version, NULL);
} else
-#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
@@ -2049,15 +2059,11 @@
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(
-#if TCL_MAJOR_VERSION > 8
void *blockPtr /* Block to free. */
-#else
- char *blockPtr /* Block to free. */
-#endif
) {
Tcl_Free(((char *)blockPtr) - 16);
}
/*
@@ -3809,11 +3815,11 @@
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/* Subcommands supported by this command */
- static const char *const subcommands[] = {
+ const char* subcommands[] = {
"new",
"describe",
"config",
"validate",
NULL
@@ -5743,28 +5749,29 @@
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
struct {
-#if !defined(TCL_NO_DEPRECATED)
- int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */
-#else
Tcl_Size n;
-#endif
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;
}
Index: generic/tclTestABSList.c
==================================================================
--- generic/tclTestABSList.c
+++ generic/tclTestABSList.c
@@ -1,6 +1,21 @@
-// Tcl Abstract List test command: "lstring"
+/*
+ * 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
@@ -14,38 +29,20 @@
*/
Tcl_Obj *myNewLStringObj(Tcl_WideInt start,
Tcl_WideInt length);
static void freeRep(Tcl_Obj* alObj);
-static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp,
- Tcl_Obj *listPtr,
- Tcl_Size numIndcies,
- Tcl_Obj *const indicies[],
- Tcl_Obj *valueObj);
-static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr);
-static int my_LStringObjIndex(Tcl_Interp *interp,
- Tcl_Obj *lstringObj,
- Tcl_Size index,
- Tcl_Obj **charObjPtr);
-static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj,
- Tcl_Size fromIdx, Tcl_Size toIdx,
- Tcl_Obj **newObjPtr);
-static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj,
- Tcl_Obj **newObjPtr);
-static int my_LStringReplace(Tcl_Interp *interp,
- Tcl_Obj *listObj,
- Tcl_Size first,
- Tcl_Size numToDelete,
- Tcl_Size numToInsert,
- Tcl_Obj *const insertObjs[]);
-static int my_LStringGetElements(Tcl_Interp *interp,
- Tcl_Obj *listPtr,
- Tcl_Size *objcptr,
- Tcl_Obj ***objvptr);
+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 void UpdateStringOfLString(Tcl_Obj *objPtr);
+static Tcl_UpdateStringProc UpdateStringOfLString;
/*
* Internal Representation of an lstring type value
*/
@@ -54,190 +51,116 @@
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 const Tcl_ObjType lstringTypes[11] = {
+
+
+static ObjectType lstringTypes[11] = {
{/*0*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
- },
+ 2,
+ NULL
+ },
{/*1*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- NULL, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*2*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- NULL, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*3*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- NULL, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*4*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- NULL, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*5*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- NULL, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*6*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- NULL, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*7*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- NULL, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*8*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*9*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
},
{/*10*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
- TCL_OBJTYPE_V2(
- my_LStringObjLength, /* Length */
- my_LStringObjIndex, /* Index */
- my_LStringObjRange, /* Slice */
- my_LStringObjReverse, /* Reverse */
- my_LStringGetElements, /* GetElements */
- my_LStringObjSetElem, /* SetElement */
- my_LStringReplace, /* Replace */
- NULL) /* "in" operator */
+ 2,
+ NULL
}
};
/*
@@ -298,15 +221,16 @@
* None.
*
*----------------------------------------------------------------------
*/
-static Tcl_Size
-my_LStringObjLength(Tcl_Obj *lstringObjPtr)
+static int
+my_LStringObjLength(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *lstringObjPtr, Tcl_Size *lenPtr )
{
LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1;
- return lstringRepPtr->strlen;
+ *lenPtr = lstringRepPtr->strlen;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -345,11 +269,11 @@
}
/*
*----------------------------------------------------------------------
*
- * my_LStringObjSetElem --
+ * 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.
*
@@ -362,36 +286,39 @@
* A new obj may be created.
*
*----------------------------------------------------------------------
*/
-static Tcl_Obj*
-my_LStringObjSetElem(
+static int
+my_LStringObjSetElemR(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size numIndicies,
- Tcl_Obj *const indicies[],
- Tcl_Obj *valueObj)
+ Tcl_Obj *const indices[],
+ Tcl_Obj *valueObj,
+ Tcl_Obj **resPtrPtr)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
Tcl_Size index;
int status;
- Tcl_Obj *returnObj;
+ Tcl_Obj *resPtr;
if (numIndicies > 1) {
Tcl_SetObjResult(interp,
- Tcl_ObjPrintf("Multiple indicies not supported by lstring."));
- return NULL;
+ Tcl_ObjPrintf("Multiple indices not supported by lstring."));
+ *resPtrPtr = NULL;
+ return TCL_ERROR;
}
- status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index);
+ status = Tcl_GetIntForIndex(interp, indices[0], lstringRepPtr->strlen, &index);
if (status != TCL_OK) {
- return NULL;
+ resPtrPtr = NULL;
+ return TCL_ERROR;
}
- returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj;
- lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1;
+ 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);
@@ -407,13 +334,14 @@
lstringRepPtr->strlen--;
memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index));
}
// else do nothing
- Tcl_InvalidateStringRep(returnObj);
+ Tcl_InvalidateStringRep(resPtr);
- return returnObj;
+ *resPtrPtr = resPtr;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
@@ -428,32 +356,33 @@
* A new Obj is created.
*
*----------------------------------------------------------------------
*/
-static int my_LStringObjRange(
+int my_LStringObjRange(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size fromIdx,
Tcl_Size toIdx,
- Tcl_Obj **newObjPtr)
+ Tcl_Obj **resPtrPtr)
{
- Tcl_Obj *rangeObj;
+ 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();
+ newObjPtr = Tcl_NewObj();
} else {
rangeRep = (LString*)Tcl_Alloc(sizeof(LString));
rangeRep->allocated = len+1;
rangeRep->strlen = len;
rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated);
@@ -468,12 +397,13 @@
if (rangeRep->strlen > 0) {
Tcl_InvalidateStringRep(rangeObj);
} else {
Tcl_InitStringRep(rangeObj, NULL, 0);
}
- *newObjPtr = rangeObj;
+ newObjPtr = rangeObj;
}
+ *resPtrPtr = newObjPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -491,41 +421,30 @@
*
*----------------------------------------------------------------------
*/
static int
-my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr)
+my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj)
{
LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *revObj;
- LString *revRep = (LString*)Tcl_Alloc(sizeof(LString));
- Tcl_ObjInternalRep itr;
Tcl_Size len;
- char *srcp, *dstp, *endp;
- (void)interp;
+ char *srcp, *endp;
+ char temp;
+ (void)interp;
+ if (Tcl_IsShared(srcObj)) {
+ Tcl_Panic("%s called with shared object", "my_LStringObjReverse");
+ }
+
len = srcRep->strlen;
- revRep->strlen = len;
- revRep->allocated = len+1;
- revRep->string = (char*)Tcl_Alloc(revRep->allocated);
- revRep->elements = NULL;
srcp = srcRep->string;
endp = &srcRep->string[len];
- dstp = &revRep->string[len];
- *dstp-- = 0;
+ endp--;
while (srcp < endp) {
- *dstp-- = *srcp++;
- }
- revObj = Tcl_NewObj();
- itr.twoPtrValue.ptr1 = revRep;
- itr.twoPtrValue.ptr2 = NULL;
- Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr);
- if (revRep->strlen > 0) {
- Tcl_InvalidateStringRep(revObj);
- } else {
- Tcl_InitStringRep(revObj, NULL, 0);
- }
- *newObjPtr = revObj;
+ temp = *endp;
+ *endp-- = *srcp;
+ *srcp++ = temp;
+ }
return TCL_OK;
}
/*
*----------------------------------------------------------------------
@@ -638,16 +557,16 @@
}
static const Tcl_ObjType *
my_SetAbstractProc(int ptype)
{
- const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */
+ 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 typePtr;
+ return (Tcl_ObjType *)typePtr;
}
/*
*----------------------------------------------------------------------
@@ -681,11 +600,11 @@
"LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
"SETELEMENT", "REPLACE", NULL
};
int i = 0;
int ptype;
- const Tcl_ObjType *lstringTypePtr = &lstringTypes[10];
+ const Tcl_ObjType *lstringTypePtr = (Tcl_ObjType *)&lstringTypes[10];
repSize = sizeof(LString);
lstringRepPtr = (LString*)Tcl_Alloc(repSize);
while (itypePtr;
char *p;
int bytesNeeded = 0;
- int llen, i;
+ int status;
+ Tcl_Size i ,llen;
/*
* Handle empty list case first, so rest of the routine is simpler.
*/
- llen = typePtr->lengthProc(objPtr);
- if (llen <= 0) {
+ status = my_LStringObjLength(NULL, objPtr, &llen);
+ if ((status != TCL_OK) || llen <= 0) {
Tcl_InitStringRep(objPtr, NULL, 0);
return;
}
/*
@@ -858,11 +777,13 @@
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);
- typePtr->indexProc(NULL, objPtr, i, &elemObj);
+
+ 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) {
@@ -883,11 +804,11 @@
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
- typePtr->indexProc(NULL, objPtr, i, &elemObj);
+ 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);
@@ -993,15 +914,16 @@
}
/*
* Abstract List Length function
*/
-static Tcl_Size
-lgenSeriesObjLength(Tcl_Obj *objPtr)
+static int
+lgenSeriesObjLength(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr, Tcl_Size *lenPtr)
{
LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1;
- return lgenSeriesRepPtr->len;
+ *lenPtr = lgenSeriesRepPtr->len;
+ return TCL_OK;
}
/*
* Abstract List Index function
*/
@@ -1088,27 +1010,24 @@
/*
* Abstract List ObjType definition
*/
-static const Tcl_ObjType lgenType = {
+
+static ObjectType lgenObjectType = {
"lgenseries",
FreeLgenInternalRep,
DupLgenSeriesRep,
UpdateStringOfLgen,
NULL, /* SetFromAnyProc */
- TCL_OBJTYPE_V2(
- lgenSeriesObjLength,
- lgenSeriesObjIndex,
- NULL, /* slice */
- NULL, /* reverse */
- NULL, /* get elements */
- NULL, /* set element */
- NULL, /* replace */
- NULL) /* "in" operator */
+ 0,
+ NULL
};
+
+static Tcl_ObjType *lgenTypePtr = (Tcl_ObjType *)&lgenObjectType;
+
/*
* ObjType Duplicate Internal Rep Function
*/
static void
DupLgenSeriesRep(
@@ -1122,11 +1041,11 @@
copyLgenSeries->interp = srcLgenSeries->interp;
copyLgenSeries->nargs = srcLgenSeries->nargs;
copyLgenSeries->len = srcLgenSeries->len;
copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj);
Tcl_IncrRefCount(copyLgenSeries->genFnObj);
- copyPtr->typePtr = &lgenType;
+ copyPtr->typePtr = lgenTypePtr;
copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
return;
}
@@ -1168,11 +1087,11 @@
// 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 = &lgenType;
+ lGenSeriesObj->typePtr = lgenTypePtr;
if (length > 0) {
Tcl_InvalidateStringRep(lGenSeriesObj);
} else {
Tcl_InitStringRep(lGenSeriesObj, NULL, 0);
@@ -1247,10 +1166,94 @@
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;
}
Index: generic/tclTestObj.c
==================================================================
--- generic/tclTestObj.c
+++ generic/tclTestObj.c
@@ -1,33 +1,45 @@
/*
- * tclTestObj.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.
- *
* Copyright © 1995-1998 Sun Microsystems, Inc.
* Copyright © 1999 Scriptics Corporation.
* Copyright © 2005 Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#undef BUILD_tcl
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
-#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */
#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
/*
* Forward declarations for functions defined later in this file:
@@ -44,10 +56,40 @@
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
@@ -77,19 +119,19 @@
/*
*----------------------------------------------------------------------
*
* TclObjTest_Init --
*
- * This function creates additional commands that are used to test the
- * Tcl object support.
+ * Creates additional commands that are used to test
+ * Tcl_Obj support.
*
* Results:
- * Returns a standard Tcl completion code, and leaves an error
- * message in the interp's result if an error occurs.
+ * Returns a standard Tcl completion code, and if an error occurs, leaves an
+ * error message in the interp result.
*
* Side effects:
- * Creates and registers several new testing commands.
+ * Creates new commands used by tests.
*
*----------------------------------------------------------------------
*/
int
@@ -115,10 +157,23 @@
}
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);
@@ -163,11 +218,11 @@
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
- static const char *const subcmds[] = {
+ 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
@@ -897,11 +952,11 @@
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
- static const char* const subcommands[] = {
+ const char* const subcommands[] = {
"set",
"get",
"replace",
"indexmemcheck",
"getelementsmemcheck",
@@ -930,11 +985,11 @@
varPtr = GetVarPtr(interp);
if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
- 0, &cmdIndex) != TCL_OK) {
+ TCL_INDEX_TEMP_TABLE, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
@@ -988,16 +1043,18 @@
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
!= TCL_OK) {
return TCL_ERROR;
}
- if (objP->refCount < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Tcl_ListObjIndex returned object with ref count < 0",
- TCL_INDEX_NONE));
- /* Keep looping since we are also looping for leaks */
- }
+ 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:
@@ -1061,36 +1118,40 @@
* Creates and frees objects.
*
*----------------------------------------------------------------------
*/
-static Tcl_Size V1TestListObjLength(TCL_UNUSED(Tcl_Obj *)) {
- return 100;
+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 V1TestListObjIndex(
- TCL_UNUSED(Tcl_Interp *),
- TCL_UNUSED(Tcl_Obj *),
- TCL_UNUSED(Tcl_Size),
- Tcl_Obj **objPtr)
+static int TestStringObjIsEmpty(
+ TCL_UNUSED(Tcl_Interp *)
+ ,TCL_UNUSED(Tcl_Obj*)
+ ,int *res)
{
- *objPtr = Tcl_NewStringObj("This indexProc should never be accessed (bug: e58d7e19e9)", -1);
+ *res = 1;
return TCL_OK;
}
-
-static const Tcl_ObjType v1TestListType = {
- "testlist", /* name */
- NULL, /* freeIntRepProc */
- NULL, /* dupIntRepProc */
- NULL, /* updateStringProc */
- NULL, /* setFromAnyProc */
- offsetof(Tcl_ObjType, indexProc), /* This is a V1 objType, which doesn't have an indexProc */
- V1TestListObjLength, /* always return 100, doesn't really matter */
- V1TestListObjIndex, /* should never be accessed, because this objType = V1*/
- NULL, NULL, NULL, NULL, NULL, NULL
-};
-
static int
TestobjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
@@ -1099,11 +1160,11 @@
{
Tcl_Size varIndex, destIndex;
int i;
const Tcl_ObjType *targetType;
Tcl_Obj **varPtr;
- static const char *const subcommands[] = {
+ const char *subcommands[] = {
"freeallvars", "bug3598580", "buge58d7e19e9",
"types", "objtype", "newobj", "set",
"assign", "convert", "duplicate",
"invalidateStringRep", "refcount", "type",
NULL
@@ -1154,12 +1215,24 @@
return TCL_OK;
case TESTOBJ_BUGE58D7E19E9:
if (objc != 3) {
goto wrongNumArgs;
} else {
- Tcl_Obj *listObjPtr = Tcl_NewStringObj(Tcl_GetString(objv[2]), -1);
- listObjPtr->typePtr = &v1TestListType;
+ 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) {
ADDED generic/tclTestObjInterface.c
Index: generic/tclTestObjInterface.c
==================================================================
--- /dev/null
+++ generic/tclTestObjInterface.c
@@ -0,0 +1,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;
+}
ADDED generic/tclTestObjInterfaceInteger.c
Index: generic/tclTestObjInterfaceInteger.c
==================================================================
--- /dev/null
+++ generic/tclTestObjInterfaceInteger.c
@@ -0,0 +1,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;
+}
Index: generic/tclTestProcBodyObj.c
==================================================================
--- generic/tclTestProcBodyObj.c
+++ generic/tclTestProcBodyObj.c
@@ -1,16 +1,27 @@
+/*
+ * 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.
- *
- * 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.
*/
#undef BUILD_tcl
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
Index: generic/tclThread.c
==================================================================
--- generic/tclThread.c
+++ generic/tclThread.c
@@ -1,18 +1,29 @@
/*
- * tclThread.c --
- *
- * This file implements Platform independent thread operations. Most of
- * the real work is done in the platform dependent files.
- *
* 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
Index: generic/tclThreadAlloc.c
==================================================================
--- generic/tclThreadAlloc.c
+++ generic/tclThreadAlloc.c
@@ -1,19 +1,30 @@
/*
- * 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.
- *
* 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
Index: generic/tclThreadJoin.c
==================================================================
--- generic/tclThreadJoin.c
+++ generic/tclThreadJoin.c
@@ -1,17 +1,28 @@
+/*
+ * 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.
- *
- * 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.
*/
#include "tclInt.h"
#ifdef _WIN32
Index: generic/tclThreadStorage.c
==================================================================
--- generic/tclThreadStorage.c
+++ generic/tclThreadStorage.c
@@ -1,18 +1,29 @@
/*
- * tclThreadStorage.c --
- *
- * This file implements platform independent thread storage operations to
- * work around system limits on the number of thread-specific variables.
- *
* 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
Index: generic/tclThreadTest.c
==================================================================
--- generic/tclThreadTest.c
+++ generic/tclThreadTest.c
@@ -1,18 +1,29 @@
+/*
+ * 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.
- *
- * 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.
*/
#undef BUILD_tcl
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
Index: generic/tclTimer.c
==================================================================
--- generic/tclTimer.c
+++ generic/tclTimer.c
@@ -1,17 +1,28 @@
/*
- * tclTimer.c --
- *
- * This file provides timer event management facilities for Tcl,
- * including the "after" command.
- *
* 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
@@ -891,14 +902,14 @@
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
- command = TclGetStringFromObj(commandPtr, &length);
+ command = Tcl_GetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
- tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
+ tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, length)) {
break;
}
Index: generic/tclTomMath.decls
==================================================================
--- generic/tclTomMath.decls
+++ generic/tclTomMath.decls
@@ -1,18 +1,26 @@
+# 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
#
-# 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.
library tcl
# Define the unsupported generic interfaces.
@@ -71,10 +79,14 @@
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)
@@ -134,38 +146,76 @@
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)
@@ -180,10 +230,23 @@
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)
@@ -191,13 +254,17 @@
# 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:
Index: generic/tclTomMath.h
==================================================================
--- generic/tclTomMath.h
+++ generic/tclTomMath.h
@@ -1,5 +1,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.
+*/
+
#ifndef BN_TCL_H_
#define BN_TCL_H_
#include
#if defined(TCL_NO_TOMMATH_H)
Index: generic/tclTomMathDecls.h
==================================================================
--- generic/tclTomMathDecls.h
+++ generic/tclTomMathDecls.h
@@ -1,17 +1,28 @@
+/*
+ * 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.
- *
- * 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.
*/
#ifndef _TCLTOMMATHDECLS
#define _TCLTOMMATHDECLS
Index: generic/tclTomMathInt.h
==================================================================
--- generic/tclTomMathInt.h
+++ generic/tclTomMathInt.h
@@ -1,3 +1,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"
Index: generic/tclTomMathInterface.c
==================================================================
--- generic/tclTomMathInterface.c
+++ generic/tclTomMathInterface.c
@@ -1,17 +1,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.
+*/
+
/*
*----------------------------------------------------------------------
*
* tclTomMathInterface.c --
*
* This file contains procedures that are used as a 'glue' layer between
* Tcl and libtommath.
- *
- * Copyright © 2005 Kevin B. Kenny. All rights reserved.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
Index: generic/tclTomMathStubLib.c
==================================================================
--- generic/tclTomMathStubLib.c
+++ generic/tclTomMathStubLib.c
@@ -1,18 +1,29 @@
/*
- * tclTomMathStubLib.c --
- *
- * Stub object that will be statically linked into extensions that want
- * to access Tcl.
- *
* 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;
Index: generic/tclTrace.c
==================================================================
--- generic/tclTrace.c
+++ generic/tclTrace.c
@@ -1,19 +1,30 @@
/*
- * tclTrace.c --
- *
- * This file contains code to handle most trace management.
- *
* 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:
*/
@@ -344,11 +355,11 @@
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
- command = TclGetStringFromObj(objv[5], &length);
+ command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
@@ -581,11 +592,11 @@
flags |= TCL_TRACE_DELETE;
break;
}
}
- command = TclGetStringFromObj(objv[5], &length);
+ command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
@@ -785,11 +796,11 @@
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
- command = TclGetStringFromObj(objv[5], &length);
+ command = Tcl_GetStringFromObj(objv[5], &length);
if (optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
Index: generic/tclUniData.c
==================================================================
--- generic/tclUniData.c
+++ generic/tclUniData.c
@@ -1,14 +1,25 @@
+/*
+ * 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.
- *
- * Copyright © 1998 Scriptics Corporation.
- * All rights reserved.
*/
/*
* 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
@@ -193,11 +204,10 @@
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
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,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, 3296, 3296, 1344, 1344, 1344, 1344,
@@ -567,11 +577,10 @@
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,
15488
-#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
@@ -1178,11 +1187,10 @@
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 92, 92, 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
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,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,
@@ -1650,11 +1658,10 @@
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 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
-#endif /* TCL_UTF_MAX > 3 */
};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
@@ -1698,15 +1705,11 @@
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 10049, 10114, 8769, 8834
};
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
-# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
-#else
-# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
-#endif
+# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0)
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
@@ -1757,10 +1760,6 @@
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
-# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
-#else
-# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
-#endif
+# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]])
Index: generic/tclUtf.c
==================================================================
--- generic/tclUtf.c
+++ generic/tclUtf.c
@@ -1,16 +1,27 @@
/*
- * tclUtf.c --
- *
- * Routines for manipulating UTF-8 strings.
- *
* 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.
*/
@@ -228,12 +239,14 @@
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 (
+ (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 */
@@ -1197,12 +1210,12 @@
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
- * Returns a pointer to the specified character (not byte) position in
- * the UTF-8 string.
+ * Returns a pointer to the specified character (not byte) position in the
+ * UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
Index: generic/tclUtil.c
==================================================================
--- generic/tclUtil.c
+++ generic/tclUtil.c
@@ -1,19 +1,30 @@
/*
- * tclUtil.c --
- *
- * This file contains utility functions that are used by many Tcl
- * commands.
- *
* 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
#include "tclInt.h"
#include "tclParse.h"
#include "tclStringTrim.h"
#include "tclTomMath.h"
@@ -127,19 +138,12 @@
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V1(TclLengthOne)
+ 0
};
-
-Tcl_Size
-TclLengthOne(
- TCL_UNUSED(Tcl_Obj *))
-{
- return 1;
-}
/*
* * STRING REPRESENTATION OF LISTS * * *
*
* The next several routines implement the conversions of strings to and from
@@ -1975,25 +1979,25 @@
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
- if (TclListObjIsCanonical(objPtr) ||
- TclObjTypeHasProc(objPtr, indexProc)) {
+ if (TclListObjIsCanonical(objPtr)
+ || TclObjectHasInterface(objPtr,list,index)) {
continue;
}
- (void)TclGetStringFromObj(objPtr, &length);
+ (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) &&
- !TclObjTypeHasProc(objPtr, indexProc)) {
+ if (!TclListObjIsCanonical(objPtr)
+ && !TclObjectHasInterface(objPtr, list, index)) {
continue;
}
if (resPtr) {
Tcl_Obj *elemPtr = NULL;
@@ -2008,11 +2012,15 @@
Tcl_BounceRefCount(elemPtr); // could be an abstract list element
goto slow;
}
Tcl_BounceRefCount(elemPtr); // could be an an abstract list element
} else {
- resPtr = TclListObjCopy(NULL, objPtr);
+ resPtr = TclDuplicatePureObj(
+ NULL, objPtr, tclListTypePtr);
+ if (!resPtr) {
+ return NULL;
+ }
}
}
if (!resPtr) {
TclNewObj(resPtr);
}
@@ -2026,11 +2034,11 @@
*
* First try to preallocate the size required.
*/
for (i = 0; i < objc; i++) {
- element = TclGetStringFromObj(objv[i], &elemLength);
+ element = Tcl_GetStringFromObj(objv[i], &elemLength);
if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) {
break; /* Overflow. Do not preallocate. See comment below. */
}
bytesNeeded += elemLength;
}
@@ -2046,11 +2054,11 @@
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
Tcl_Size triml, trimr;
- element = TclGetStringFromObj(objv[i], &elemLength);
+ 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;
@@ -2666,11 +2674,11 @@
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
Tcl_Size length;
- const char *bytes = TclGetStringFromObj(objPtr, &length);
+ const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
@@ -3506,26 +3514,23 @@
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
- const char *bytes = TclGetStringFromObj(objPtr, &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" */
- /* If we reach here, the string rep of objPtr exists. */
-
/*
- * The valid index syntax does not include any value that is
- * a list of more than one element. This is necessary so that
- * lists of index values can be reliably distinguished from any
- * single index value.
+ * 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.
@@ -3638,10 +3643,11 @@
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 */
@@ -3919,14 +3925,14 @@
*indexPtr = idx;
return TCL_OK;
rangeerror:
if (interp) {
- Tcl_SetObjResult(
- interp,
+ Tcl_SetObjResult(interp,
Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr)));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL);
+ Tcl_SetErrorCode(interp,
+ "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL);
}
return TCL_ERROR;
}
/*
@@ -3956,10 +3962,75 @@
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 --
Index: generic/tclVar.c
==================================================================
--- generic/tclVar.c
+++ generic/tclVar.c
@@ -1,14 +1,6 @@
/*
- * 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.
- *
* 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
@@ -15,10 +7,29 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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.
@@ -247,11 +258,11 @@
*/
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
- TCL_OBJTYPE_V0
+ 0
};
#define LocalSetInternalRep(objPtr, index, namePtr) \
do { \
Tcl_ObjInternalRep ir; \
@@ -271,11 +282,11 @@
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL,
- TCL_OBJTYPE_V0
+ 0
};
#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
do { \
Tcl_ObjInternalRep ir; \
@@ -663,11 +674,11 @@
/*
* part1Ptr is possibly an unparsed array element.
*/
Tcl_Size len;
- const char *part1 = TclGetStringFromObj(part1Ptr, &len);
+ const char *part1 = Tcl_GetStringFromObj(part1Ptr, &len);
if ((len > 1) && (part1[len - 1] == ')')) {
const char *part2 = strchr(part1, '(');
if (part2) {
@@ -844,13 +855,13 @@
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 = TclGetStringFromObj(varNamePtr, &varLen);
+ 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;
@@ -981,11 +992,11 @@
for (i=0 ; icompiledLocals[i];
@@ -3133,11 +3144,11 @@
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
- varListObj = TclListObjCopy(NULL, objv[1]);
+ varListObj = TclDuplicatePureObj(interp, objv[1], tclListTypePtr);
if (!varListObj) {
return TCL_ERROR;
}
scriptObj = objv[3];
Tcl_IncrRefCount(scriptObj);
@@ -4032,11 +4043,11 @@
/*
* Install the contents of the dictionary or list into the array.
*/
arrayElemObj = objv[2];
- if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) {
+ if (TclHasInternalRep(arrayElemObj, tclDictTypePtr) && arrayElemObj->bytes == NULL) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
Tcl_Size size;
@@ -4109,11 +4120,12 @@
* 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 = TclListObjCopy(NULL, arrayElemObj);
+ copyListObj =
+ TclDuplicatePureObj(interp, arrayElemObj, tclListTypePtr);
if (!copyListObj) {
return TCL_ERROR;
}
for (i=0 ; i
* Copyright © 2013-2015 Christian Werner
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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.
@@ -1027,11 +1038,11 @@
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
- normalizedPath = TclGetStringFromObj(normalizedObj, &normalizedLen);
+ normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen);
Tcl_DStringFree(&dsJoin);
Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
Tcl_DecrRefCount(normalizedObj);
return TCL_OK;
@@ -1114,11 +1125,11 @@
}
Tcl_IncrRefCount(normalizedObj); /* BEFORE DecrRefCount on unnormalizedObj */
Tcl_DecrRefCount(unnormalizedObj);
/* normalizedObj owned by Tcl!! Do NOT DecrRef without an IncrRef */
- normalizedPath = TclGetStringFromObj(normalizedObj, &normalizedLen);
+ normalizedPath = Tcl_GetStringFromObj(normalizedObj, &normalizedLen);
Tcl_DStringAppend(dsPtr, normalizedPath, normalizedLen);
Tcl_DecrRefCount(normalizedObj);
return Tcl_DStringValue(dsPtr);
}
@@ -1388,11 +1399,11 @@
* 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.
+ * 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.
@@ -1486,11 +1497,11 @@
* 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 &&
+ if (!(cdirZipOffset <= eocdDataOffset &&
cdirSize <= eocdDataOffset - cdirZipOffset)) {
if (!needZip) {
/* Simply point to end od data */
zf->directoryOffset = zf->baseOffset = zf->passOffset = zf->length;
return TCL_OK;
@@ -1591,11 +1602,11 @@
* 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
+ * 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.
@@ -1769,11 +1780,11 @@
/*
* Determine the file size.
*/
zf->length = lseek(fd, 0, SEEK_END);
- if (zf->length == (size_t)-1) {
+ if ((off_t)zf->length == (off_t)-1) {
ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size");
return TCL_ERROR;
}
if (zf->length < ZIP_CENTRAL_END_LEN) {
Tcl_SetErrno(EINVAL);
@@ -1828,11 +1839,11 @@
* 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!!
+ * into the given interp if it is not NULL. On error, frees zf!!
*
* Side effects:
* Will acquire and release the write lock.
*
*-------------------------------------------------------------------------
@@ -2754,11 +2765,11 @@
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
- pw = TclGetStringFromObj(objv[1], &len);
+ pw = Tcl_GetStringFromObj(objv[1], &len);
if (len == 0) {
return TCL_OK;
}
if (IsPasswordValid(interp, pw, len) != TCL_OK) {
return TCL_ERROR;
@@ -3286,11 +3297,11 @@
Tcl_Size len;
if (directNameObj) {
name = TclGetString(directNameObj);
} else {
- name = TclGetStringFromObj(pathObj, &len);
+ name = Tcl_GetStringFromObj(pathObj, &len);
if (slen > 0) {
if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
/*
* Guaranteed to be a NUL at the end, which will make this
* entry be skipped.
@@ -3373,11 +3384,11 @@
* Caller has verified that the number of arguments is correct.
*/
passBuf[0] = 0;
if (passwordObj != NULL) {
- pw = TclGetStringFromObj(passwordObj, &pwlen);
+ pw = Tcl_GetStringFromObj(passwordObj, &pwlen);
if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) {
return TCL_ERROR;
}
if (pwlen == 0) {
pw = NULL;
@@ -3532,11 +3543,11 @@
* Prepare the contents of the ZIP archive.
*/
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
if (mappingList == NULL && stripPrefix != NULL) {
- strip = TclGetStringFromObj(stripPrefix, &slen);
+ strip = Tcl_GetStringFromObj(stripPrefix, &slen);
if (!slen) {
strip = NULL;
}
}
for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) {
@@ -5564,17 +5575,17 @@
/*
* The prefix that gets prepended to results.
*/
- prefix = TclGetStringFromObj(pathPtr, &prefixLen);
+ prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
/*
* The (normalized) path we're searching.
*/
- path = TclGetStringFromObj(normPathPtr, &len);
+ path = Tcl_GetStringFromObj(normPathPtr, &len);
Tcl_DStringInit(&dsPref);
if (strcmp(prefix, path) == 0) {
prefixBuf = NULL;
} else {
@@ -5749,11 +5760,11 @@
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int l;
Tcl_Size normLength;
- const char *path = TclGetStringFromObj(normPathPtr, &normLength);
+ const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength);
Tcl_Size len = normLength;
if (len < 1) {
/*
* Shouldn't happen. But "shouldn't"...
@@ -5836,11 +5847,11 @@
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
- path = TclGetStringFromObj(pathPtr, &len);
+ 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).
@@ -5955,11 +5966,11 @@
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
- path = TclGetStringFromObj(pathPtr, &len);
+ path = Tcl_GetStringFromObj(pathPtr, &len);
ReadLock();
z = ZipFSLookup(path);
if (!z && !ContainsMountPoint(path, -1)) {
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
Index: generic/tclZlib.c
==================================================================
--- generic/tclZlib.c
+++ generic/tclZlib.c
@@ -1,10 +1,6 @@
/*
- * tclZlib.c --
- *
- * This file provides the interface to the Zlib library.
- *
* Copyright © 2004-2005 Pascal Scheffers
* 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
@@ -12,10 +8,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.
+*/
+
+/*
+ * tclZlib.c --
+ *
+ * This file provides the interface to the Zlib library.
+ */
+
#include "tclInt.h"
#ifdef HAVE_ZLIB
#include
#include "tclIO.h"
@@ -449,11 +460,11 @@
if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
- valueStr = TclGetStringFromObj(value, &length);
+ 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) {
@@ -485,11 +496,11 @@
if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
Tcl_EncodingState state;
- valueStr = TclGetStringFromObj(value, &length);
+ 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) {
@@ -3538,12 +3549,12 @@
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
if (chanDataPtr->compDictObj) {
Tcl_Size length;
- const char *str = TclGetStringFromObj(chanDataPtr->compDictObj,
- &length);
+ const char *str = Tcl_GetStringFromObj(chanDataPtr->compDictObj,
+ &length);
Tcl_DStringAppend(dsPtr, str, length);
}
return TCL_OK;
}
Index: library/auto.tcl
==================================================================
--- library/auto.tcl
+++ library/auto.tcl
@@ -6,11 +6,17 @@
# 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
@@ -305,11 +311,11 @@
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 -encoding utf-8 \[file join \$dir [list $file]\]\]\n"
+ append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
@@ -592,11 +598,11 @@
set name [string range [list \}[fullname $name]] 2 end]
set filenameParts [file split $scriptFile]
append index [format \
- {set auto_index(%s) [list source -encoding utf-8 [file join $dir %s]]%s} \
+ {set auto_index(%s) [list source [file join $dir %s]]%s} \
$name $filenameParts \n]
return
}
if {[llength $::auto_mkindex_parser::initCommands]} {
Index: library/clock.tcl
==================================================================
--- library/clock.tcl
+++ library/clock.tcl
@@ -1,26 +1,35 @@
-#----------------------------------------------------------------------
+# 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.
#
#
-#----------------------------------------------------------------------
-#
-# Copyright © 2004-2007 Kevin B. Kenny
-# Copyright © 2015 Sergey G. Brester aka sebres.
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-#----------------------------------------------------------------------
-
-# msgcat 1.7 features are used.
-
-package require msgcat 1.7
+
+# 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 }] } {
+ namespace eval ::tcl::clock [list 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.
namespace eval ::tcl::clock \
@@ -49,11 +58,13 @@
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
}
#----------------------------------------------------------------------
@@ -276,17 +287,10 @@
# Day before Leap Day
variable FEB_28 58
- # Default configuration
-
- ::tcl::unsupported::clock::configure -current-locale [mclocale]
- #::tcl::unsupported::clock::configure -default-locale C
- #::tcl::unsupported::clock::configure -year-century 2000 \
- # -century-switch 38
-
# 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.
@@ -378,10 +382,156 @@
{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 \
@@ -475,163 +625,1673 @@
z +0000 \
]
# Caches
- variable LocFmtMap [dict create]; # Dictionary with localized format maps
-
- variable TimeZoneBad [dict create]; # Dictionary whose keys are time zone
+ 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 mcLocales [dict create]; # Dictionary with loaded locales
- variable mcMergedCat [dict create]; # Dictionary with merged locale catalogs
+ variable FormatProc; # Array mapping format group
+ # and locale to the name of a procedure
+ # that renders the given format
}
::tcl::clock::Initialize
#----------------------------------------------------------------------
-
-# mcget --
-#
-# Return the merged translation catalog for the ::tcl::clock namespace
-# Searching of catalog is similar to "msgcat::mc".
-#
-# Contrary to "msgcat::mc" may additionally load a package catalog
-# on demand.
-#
-# Arguments:
-# loc The locale used for translation.
-#
-# Results:
-# Returns the dictionary object as whole catalog of the package/locale.
-#
-proc ::tcl::clock::mcget {loc} {
- variable mcMergedCat
- switch -- $loc system {
- set loc [GetSystemLocale]
- } current {
- set loc [mclocale]
- }
- if {$loc ne {}} {
- set loc [string tolower $loc]
- }
-
- # try to retrieve now if already available:
- if {[dict exists $mcMergedCat $loc]} {
- return [dict get $mcMergedCat $loc]
- }
-
- # get locales list for given locale (de_de -> {de_de de {}})
- variable mcLocales
- if {[dict exists $mcLocales $loc]} {
- set loclist [dict get $mcLocales $loc]
- } else {
- # save current locale:
- set prevloc [mclocale]
- # lazy load catalog on demand (set it will load the catalog)
- mcpackagelocale set $loc
- set loclist [msgcat::mcutil::getpreferences $loc]
- dict set $mcLocales $loc $loclist
- # restore:
- if {$prevloc ne $loc} {
- mcpackagelocale set $prevloc
- }
- }
- # get whole catalog:
- mcMerge $loclist
-}
-
-# mcMerge --
-#
-# Merge message catalog dictionaries to one dictionary.
-#
-# Arguments:
-# locales List of locales to merge.
-#
-# Results:
-# Returns the (weak pointer) to merged dictionary of message catalog.
-#
-proc ::tcl::clock::mcMerge {locales} {
- variable mcMergedCat
- if {[dict exists $mcMergedCat [set loc [lindex $locales 0]]]} {
- return [dict get $mcMergedCat $loc]
- }
- # package msgcat currently does not provide possibility to get whole catalog:
- upvar ::msgcat::Msgs Msgs
- set ns ::tcl::clock
- # Merge sequential locales (in reverse order, e. g. {} -> en -> en_en):
- if {[llength $locales] > 1} {
- set mrgcat [mcMerge [lrange $locales 1 end]]
- if {[dict exists $Msgs $ns $loc]} {
- set mrgcat [dict merge $mrgcat [dict get $Msgs $ns $loc]]
- dict set mrgcat L $loc
- } else {
- # be sure a duplicate is created, don't overwrite {} (common) locale:
- set mrgcat [dict merge $mrgcat [dict create L $loc]]
- }
- } else {
- if {[dict exists $Msgs $ns $loc]} {
- set mrgcat [dict get $Msgs $ns $loc]
- dict set mrgcat L $loc
- } else {
- # be sure a duplicate is created, don't overwrite {} (common) locale:
- set mrgcat [dict create L $loc]
- }
- }
- dict set mcMergedCat $loc $mrgcat
- # return smart reference (shared dict as object with exact one ref-counter)
- return $mrgcat
-}
-
-#----------------------------------------------------------------------
-#
-# GetSystemLocale --
-#
-# Determines the system locale, which corresponds to "system"
-# keyword for locale parameter of 'clock' command.
-#
-# Parameters:
-# None.
-#
-# Results:
-# Returns the system locale.
-#
-# Side effects:
-# None.
-#
-#----------------------------------------------------------------------
-
-proc ::tcl::clock::GetSystemLocale {} {
- if { $::tcl_platform(platform) ne {windows} } {
- # On a non-windows platform, the 'system' locale is the same as
- # the 'current' locale
-
- return [mclocale]
- }
-
- # 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
- }
-
- return $locale
+#
+# 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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock 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 ::tcl::clock::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 ::tcl::clock::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 {
+ ::tcl::clock::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 [::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
+
+ set currPrio 999
+ set currFieldPos [list]
+ set currCodeBurst {
+ error "in ::tcl::clock::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 --
@@ -643,51 +2303,43 @@
#
# Results:
# Returns the locale that was previously current.
#
# Side effects:
-# Does [mclocale]. If necessary, loades the designated locale's files.
+# Does [mclocale]. If necessary, loads the designated locale's files.
#
#----------------------------------------------------------------------
proc ::tcl::clock::EnterLocale { locale } {
- switch -- $locale system {
- set locale [GetSystemLocale]
- } current {
+ 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]
}
- # Select the locale, eventually load it
+ # Eventually load the locale
mcpackagelocale set $locale
- return $locale
-}
-
-#----------------------------------------------------------------------
-#
-# _hasRegistry --
-#
-# Helper that checks whether registry module is available (Windows only)
-# and loads it on demand.
-#
-#----------------------------------------------------------------------
-proc ::tcl::clock::_hasRegistry {} {
- set res 0
- if { $::tcl_platform(platform) eq {windows} } {
- if { [catch { package require registry 1.1 }] } {
- # try to load registry directly from root (if uninstalled / development env):
- if {[regexp {[/\\]library$} [info library]]} {catch {
- load [lindex \
- [glob -tails -directory [file dirname [info nameofexecutable]] \
- tclreg*[expr {[::tcl::pkgconfig get debug] ? {g} : {}}].dll] 0 \
- ] registry
- }}
- }
- if { [namespace which -command ::registry] ne "" } {
- set res 1
- }
- }
- proc ::tcl::clock::_hasRegistry {} [list return $res]
- return $res
}
#----------------------------------------------------------------------
#
# LoadWindowsDateTimeFormats --
@@ -711,11 +2363,12 @@
#----------------------------------------------------------------------
proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
# Bail out if we can't find the Registry
- if { ![_hasRegistry] } return
+ variable NoRegistry
+ if { [info exists NoRegistry] } return
if { ![catch {
registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
sShortDate
} string] } {
@@ -822,12 +2475,10 @@
#
# Parameters:
# locale -- Current [mclocale] locale, supplied to avoid
# an extra call
# format -- Format supplied to [clock scan] or [clock format]
-# mcd -- Message catalog dictionary for current locale (read-only,
-# don't store it to avoid shared references).
#
# Results:
# Returns the string with locale-dependent composite format groups
# substituted out.
#
@@ -834,55 +2485,489 @@
# Side effects:
# None.
#
#----------------------------------------------------------------------
-proc ::tcl::clock::LocalizeFormat { locale format mcd } {
- variable LocFmtMap
+proc ::tcl::clock::LocalizeFormat { locale format } {
- # get map list cached or build it:
- if {[dict exists $LocFmtMap $locale]} {
- set mlst [dict get $LocFmtMap $locale]
+ # 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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::InterpretTwoDigitYear { date baseTime
+ { twoDigitField yearOfCentury }
+ { fourDigitField year } } {
+ set yr [dict get $date $twoDigitField]
+ if { $yr <= 37 } {
+ dict set date $fourDigitField [expr { $yr + 2000 }]
} else {
- # 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 mlst {
- %% %%
- %D %m/%d/%Y
- %+ {%a %b %e %H:%M:%S %Z %Y}
- }
- lappend mlst %EY [string map $mlst [dict get $mcd LOCALE_YEAR_FORMAT]]
- lappend mlst %T [string map $mlst [dict get $mcd TIME_FORMAT_24_SECS]]
- lappend mlst %R [string map $mlst [dict get $mcd TIME_FORMAT_24]]
- lappend mlst %r [string map $mlst [dict get $mcd TIME_FORMAT_12]]
- lappend mlst %X [string map $mlst [dict get $mcd TIME_FORMAT]]
- lappend mlst %EX [string map $mlst [dict get $mcd LOCALE_TIME_FORMAT]]
- lappend mlst %x [string map $mlst [dict get $mcd DATE_FORMAT]]
- lappend mlst %Ex [string map $mlst [dict get $mcd LOCALE_DATE_FORMAT]]
- lappend mlst %c [string map $mlst [dict get $mcd DATE_TIME_FORMAT]]
- lappend mlst %Ec [string map $mlst [dict get $mcd LOCALE_DATE_TIME_FORMAT]]
-
- dict set LocFmtMap $locale $mlst
- }
-
- # translate copy of format (don't use format object here, because otherwise
- # it can lose its internal representation (string map - convert to unicode)
- set locfmt [string map $mlst [string range " $format" 1 end]]
-
- # Save original format as long as possible, because of internal
- # representation (performance).
- # Note that in this case such format will be never localized (also
- # using another locales). To prevent this return a duplicate (but
- # it may be slower).
- if {$locfmt eq $format} {
- set locfmt $format
- }
-
- return $locfmt
+ 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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::InterpretHMS { date } {
+ return [expr {
+ ( [dict get $date hour] * 60
+ + [dict get $date minute] ) * 60
+ + [dict get $date second]
+ }]
}
#----------------------------------------------------------------------
#
# GetSystemTimeZone --
@@ -895,50 +2980,79 @@
#
# Results:
# Returns the system time zone.
#
# Side effects:
-# Stores the system time zone in engine configuration, since
-# determining it may be an expensive process.
+# Stores the system time zone in the 'CachedSystemTimeZone'
+# variable, since determining it may be an expensive process.
#
#----------------------------------------------------------------------
proc ::tcl::clock::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 {
- # ask engine for the cached timezone:
- set timezone [::tcl::unsupported::clock::configure -system-tz]
- if { $timezone ne "" } {
- return $timezone
- }
- if { $::tcl_platform(platform) eq {windows} } {
+ # 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] } {
- catch {set timezone [SetupTimeZone $timezone]}
- }
-
- if { [dict exists $TimeZoneBad $timezone] } {
- set timezone :localtime
- }
-
- # tell backend - current system timezone:
- ::tcl::unsupported::clock::configure -system-tz $timezone
-
- return $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 ::tcl::clock::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 --
@@ -954,23 +3068,19 @@
# the lookup table for local<->UTC conversion. Returns an error if the
# time zone cannot be parsed.
#
#----------------------------------------------------------------------
-proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } {
+proc ::tcl::clock::SetupTimeZone { timezone } {
variable TZData
if {! [info exists TZData($timezone)] } {
-
- variable TimeZoneBad
- if { [dict exists $TimeZoneBad $timezone] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $timezone] \
- "time zone \"$timezone\" not found"
- }
variable MINWIDE
- if {
+ 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
@@ -999,11 +3109,10 @@
LoadTimeZoneFile [string range $timezone 1 end]
}] && [catch {
LoadZoneinfoFile [string range $timezone 1 end]
}]
} then {
- dict set TimeZoneBad $timezone 1
return -code error \
-errorcode [list CLOCK badTimeZone $timezone] \
"time zone \"$timezone\" not found"
}
} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
@@ -1011,47 +3120,29 @@
if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
dict unset opts -errorinfo
}
- dict set TimeZoneBad $timezone 1
return -options $opts $data
} else {
set TZData($timezone) $data
}
} else {
-
- variable LegacyTimeZone
-
# 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] } {
-
- # Check may be a legacy zone:
-
- if { $alias eq {} && ![catch {
- set tzname [dict get $LegacyTimeZone [string tolower $timezone]]
- }] } {
- set tzname [::tcl::clock::SetupTimeZone $tzname $timezone]
- set TZData($timezone) $TZData($tzname)
- # tell backend - timezone is initialized and return shared timezone object:
- return [::tcl::unsupported::clock::configure -setup-tz $timezone]
- }
-
dict unset opts -errorinfo
- dict set TimeZoneBad $timezone 1
return -options $opts "time zone $timezone not found"
}
set TZData($timezone) $TZData(:$timezone)
}
}
- # tell backend - timezone is initialized and return shared timezone object:
- ::tcl::unsupported::clock::configure -setup-tz $timezone
+ return
}
#----------------------------------------------------------------------
#
# GuessWindowsTimeZone --
@@ -1077,13 +3168,14 @@
#
#----------------------------------------------------------------------
proc ::tcl::clock::GuessWindowsTimeZone {} {
variable WinZoneInfo
+ variable NoRegistry
variable TimeZoneBad
- if { ![_hasRegistry] } {
+ if { [info exists NoRegistry] } {
return :localtime
}
# Dredge time zone information out of the registry
@@ -1117,16 +3209,16 @@
# (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] } {
- catch {set tzname [SetupTimeZone $tzname]}
+ dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
}
} else {
set tzname {}
}
- if { $tzname eq {} || [dict exists $TimeZoneBad $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 \
@@ -1793,18 +3885,18 @@
variable FEB_28
# Determine the start or end day of DST
- set date [dict create era CE year $y gregorian 1]
+ 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 $date]
+ && [IsGregorianLeapYear $y]
&& ( $doy > $FEB_28 ) } {
incr doy
}
dict set date dayOfYear $doy
set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
@@ -1846,10 +3938,47 @@
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 ::tcl::clock::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 --
#
@@ -2026,10 +4155,337 @@
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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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 ::tcl::clock::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.
#
@@ -2043,11 +4499,24 @@
# Buffered parse functions are cleared.
#
#----------------------------------------------------------------------
proc ::tcl::clock::ChangeCurrentLocale {args} {
- ::tcl::unsupported::clock::configure -current-locale [lindex $args 0]
+ 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 --
@@ -2064,19 +4533,23 @@
# Caches are cleared.
#
#----------------------------------------------------------------------
proc ::tcl::clock::ClearCaches {} {
- variable LocFmtMap
- variable mcMergedCat
+ variable FormatProc
+ variable LocaleNumeralCache
+ variable CachedSystemTimeZone
variable TimeZoneBad
- # tell backend - should invalidate:
- ::tcl::unsupported::clock::configure -clear
-
- # clear msgcat cache:
- set mcMergedCat [dict create]
+ foreach p [info procs [namespace current]::scanproc'*] {
+ rename $p {}
+ }
+ foreach p [info procs [namespace current]::formatproc'*] {
+ rename $p {}
+ }
- set LocFmtMap {}
+ catch {unset FormatProc}
+ set LocaleNumeralCache {}
+ catch {unset CachedSystemTimeZone}
set TimeZoneBad {}
InitTZData
}
Index: library/cookiejar/cookiejar.tcl
==================================================================
--- library/cookiejar/cookiejar.tcl
+++ library/cookiejar/cookiejar.tcl
@@ -1,13 +1,20 @@
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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).
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Dependencies
package require Tcl 8.6-
package require http 2.8.4
package require sqlite3
Index: library/cookiejar/idna.tcl
==================================================================
--- library/cookiejar/idna.tcl
+++ library/cookiejar/idna.tcl
@@ -1,18 +1,25 @@
+# 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; the
-# other parts are:
-# Copyright © 2014 Donal K. Fellows
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# This implementation includes code from that RFC, translated to Tcl.
namespace eval ::tcl::idna {
namespace ensemble create -command puny -map {
encode punyencode
decode punydecode
Index: library/history.tcl
==================================================================
--- library/history.tcl
+++ library/history.tcl
@@ -1,13 +1,20 @@
-# history.tcl --
-#
-# Implementation of the history command.
-#
# 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.
#
Index: library/http/http.tcl
==================================================================
--- library/http/http.tcl
+++ library/http/http.tcl
@@ -1,14 +1,21 @@
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
package provide http 2.10b2
@@ -1782,14 +1789,11 @@
set delay [expr {[clock milliseconds] - $pre}]
if {$delay > 3000} {
Log socket delay $delay - token $token
}
fconfigure $sock -translation {auto crlf} \
- -buffersize $state(-blocksize)
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- fconfigure $sock -profile replace
- }
+ -buffersize $state(-blocksize) -profile strict
##Log socket opened, DONE fconfigure - token $token
}
Log "Using $sock for $state(socketinfo) - token $token" \
[expr {$state(-keepalive)?"keepalive":""}]
@@ -2203,14 +2207,11 @@
# 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)
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- fconfigure $sock -profile replace
- }
+ -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}
@@ -2596,14 +2597,11 @@
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)
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- fconfigure $sock -profile replace
- }
+ -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]
@@ -4591,15 +4589,12 @@
# IANA charset. However, we only know how to convert what we have
# encodings for.
set enc [CharsetToEncoding $state(charset)]
if {$enc ne "binary"} {
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- set state(body) [encoding convertfrom -profile replace $enc $state(body)]
- } else {
- set state(body) [encoding convertfrom $enc $state(body)]
- }
+ 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)]
}
@@ -4678,15 +4673,11 @@
}
set enc [CharsetToEncoding $res]
if {$enc eq "binary"} {
return 0
}
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- set state(body) [encoding convertfrom -profile replace $enc $state(body)]
- } else {
- set state(body) [encoding convertfrom $enc $state(body)]
- }
+ 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
@@ -4763,15 +4754,11 @@
# 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]
- if {[package vsatisfies [package provide Tcl] 9.0-]} {
- set string [encoding convertto -profile replace $http(-urlencoding) $string]
- } else {
- set string [encoding convertto $http(-urlencoding) $string]
- }
+ set string [encoding convertto -profile strict $http(-urlencoding) $string]
return [string map $formMap $string]
}
# http::ProxyRequired --
# Default proxy filter.
Index: library/init.tcl
==================================================================
--- library/init.tcl
+++ library/init.tcl
@@ -1,10 +1,5 @@
-# init.tcl --
-#
-# Default system startup file for Tcl-based applications. Defines
-# "unknown" procedure and auto-load facilities.
-#
# 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
@@ -11,11 +6,22 @@
#
# 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.
+
+# init.tcl --
#
+# Default system startup file for Tcl-based applications. Defines
+# "unknown" procedure and auto-load facilities.
package require -exact tcl 9.0b2
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -107,21 +113,26 @@
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
}
# Set up the 'clock' ensemble
- proc clock args {
- set cmdmap [dict create]
- foreach cmd {add clicks format microseconds milliseconds scan seconds} {
- dict set cmdmap $cmd ::tcl::clock::$cmd
- }
- namespace inscope ::tcl::clock [list namespace ensemble create -command \
- [uplevel 1 [list ::namespace origin [::lindex [info level 0] 0]]] \
- -map $cmdmap]
- ::tcl::unsupported::clock::configure -init-complete
- uplevel 1 [info level 0]
- }
+ namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
+
+ proc ::tcl::initClock {} {
+ # Auto-loading stubs for 'clock.tcl'
+
+ foreach cmd {add format scan} {
+ proc ::tcl::clock::$cmd args {
+ variable TclLibDir
+ source [file join $TclLibDir clock.tcl]
+ return [uplevel 1 [info level 0]]
+ }
+ }
+
+ rename ::tcl::initClock {}
+ }
+ ::tcl::initClock
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
@@ -301,11 +312,11 @@
::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]
+ set ret [catch [list uplevel 1 [list ::info commands $name*]] candidates]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
dict append opts -errorinfo \
Index: library/install.tcl
==================================================================
--- library/install.tcl
+++ library/install.tcl
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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} {
Index: library/msgcat/msgcat.tcl
==================================================================
--- library/msgcat/msgcat.tcl
+++ library/msgcat/msgcat.tcl
@@ -1,17 +1,24 @@
-# 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".
-#
# 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.
Index: library/opt/optparse.tcl
==================================================================
--- library/opt/optparse.tcl
+++ library/opt/optparse.tcl
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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.
#
Index: library/opt/pkgIndex.tcl
==================================================================
--- library/opt/pkgIndex.tcl
+++ library/opt/pkgIndex.tcl
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: library/package.tcl
==================================================================
--- library/package.tcl
+++ library/package.tcl
@@ -6,11 +6,17 @@
# 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 --
#
Index: library/parray.tcl
==================================================================
--- library/parray.tcl
+++ library/parray.tcl
@@ -4,11 +4,17 @@
# 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"
Index: library/platform/platform.tcl
==================================================================
--- library/platform/platform.tcl
+++ library/platform/platform.tcl
@@ -1,6 +1,12 @@
-# -*- tcl -*-
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: library/platform/shell.tcl
==================================================================
--- library/platform/shell.tcl
+++ library/platform/shell.tcl
@@ -1,7 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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 -*-
# ### ### ### ######### ######### #########
## Overview
# Higher-level commands which invoke the functionality of this package
# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
Index: library/safe.tcl
==================================================================
--- library/safe.tcl
+++ library/safe.tcl
@@ -1,25 +1,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.
+
# 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.
-#
-# 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.
-#
# 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
Index: library/tclIndex
==================================================================
--- library/tclIndex
+++ library/tclIndex
@@ -17,33 +17,10 @@
set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::indexEntry) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
-set auto_index(::tcl::clock::Initialize) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::mcget) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::mcMerge) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::GetSystemLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::EnterLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::_hasRegistry) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::LoadWindowsDateTimeFormats) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::LocalizeFormat) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::GetSystemTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::SetupTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::GuessWindowsTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::LoadTimeZoneFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::LoadZoneinfoFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::ReadZoneinfoFile) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::ParsePosixTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::ProcessPosixTimeZone) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::DeterminePosixDSTTime) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::GetJulianDayFromEraYearDay) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::GetJulianDayFromEraYearMonthWeekDay) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::IsGregorianLeapYear) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::WeekdayOnOrBefore) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::ChangeCurrentLocale) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
-set auto_index(::tcl::clock::ClearCaches) [list ::tcl::Pkg::source [file join $dir clock.tcl]]
set auto_index(foreachLine) [list ::tcl::Pkg::source [file join $dir foreachline.tcl]]
set auto_index(::tcl::history) [list ::tcl::Pkg::source [file join $dir history.tcl]]
set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]]
set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]]
set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]]
Index: library/tcltest/pkgIndex.tcl
==================================================================
--- library/tcltest/pkgIndex.tcl
+++ library/tcltest/pkgIndex.tcl
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: library/tcltest/tcltest.tcl
==================================================================
--- library/tcltest/tcltest.tcl
+++ library/tcltest/tcltest.tcl
@@ -1,5 +1,18 @@
+# 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,
@@ -7,16 +20,10 @@
# details.
#
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Microsystems.
-#
-# 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.
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
@@ -401,11 +408,11 @@
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
if {$fullutf} {
- fconfigure $outputChannel -profile tcl8 -encoding utf-8
+ 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
@@ -449,11 +456,11 @@
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
if {$fullutf} {
- fconfigure $errorChannel -profile tcl8 -encoding utf-8
+ 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
@@ -796,11 +803,11 @@
variable fullutf
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {$fullutf} {
- fconfigure $tmp -profile tcl8 -encoding utf-8
+ fconfigure $tmp -encoding utf-8
}
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
@@ -1137,10 +1144,11 @@
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
@@ -1381,11 +1389,11 @@
variable fullutf
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {$fullutf} {
- fconfigure $f -profile tcl8 -encoding utf-8
+ fconfigure $f -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
@@ -2233,11 +2241,11 @@
} else {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {$fullutf} {
- fconfigure $testFd -profile tcl8 -encoding utf-8
+ fconfigure $testFd -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
@@ -2264,15 +2272,11 @@
}
if {$processTest && $scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
- if {[catch {
- puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
- } errMsg]} {
- puts [outputChannel] "\n---- Result was:\n"
- }
+ puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
puts [outputChannel] "---- Result should have been\
($match matching):\n[Asciify $result]"
}
}
if {$errorCodeFailure} {
@@ -2950,11 +2954,11 @@
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {$fullutf} {
- fconfigure $pipeFd -profile tcl8 -encoding utf-8
+ fconfigure $pipeFd -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
@@ -3152,11 +3156,11 @@
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {$fullutf} {
- fconfigure $fd -profile tcl8 -encoding utf-8
+ fconfigure $fd -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
@@ -3305,11 +3309,11 @@
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {$fullutf} {
- fconfigure $f -profile tcl8 -encoding utf-8
+ fconfigure $f -encoding utf-8
}
set data [read -nonewline $f]
close $f
return $data
}
Index: library/tm.tcl
==================================================================
--- library/tm.tcl
+++ library/tm.tcl
@@ -1,11 +1,15 @@
-# -*- tcl -*-
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: library/word.tcl
==================================================================
--- library/word.tcl
+++ library/word.tcl
@@ -1,16 +1,23 @@
-# 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.
-#
# 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.
DELETED libtommath/appveyor.yml
Index: libtommath/appveyor.yml
==================================================================
--- libtommath/appveyor.yml
+++ /dev/null
@@ -1,20 +0,0 @@
-version: 1.3.0-{build}
-branches:
- only:
- - master
- - develop
- - /^release/
- - /^travis/
-image:
-- Visual Studio 2019
-- Visual Studio 2017
-- Visual Studio 2015
-build_script:
-- cmd: >-
- if "Visual Studio 2019"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars64.bat"
- if "Visual Studio 2017"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars64.bat"
- if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64
- if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\vcvarsall.bat" x86_amd64
- nmake -f makefile.msvc all
-test_script:
-- cmd: test.exe
Index: libtommath/bn_mp_root_n.c
==================================================================
--- libtommath/bn_mp_root_n.c
+++ libtommath/bn_mp_root_n.c
@@ -16,11 +16,11 @@
{
mp_int t1, t2, t3, a_;
int ilog2;
mp_err err;
- if ((unsigned)b > (unsigned)MP_MIN(MP_DIGIT_MAX, INT_MAX)) {
+ 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)) {
DELETED libtommath/helper.pl
Index: libtommath/helper.pl
==================================================================
--- libtommath/helper.pl
+++ /dev/null
@@ -1,512 +0,0 @@
-#!/usr/bin/env perl
-
-use strict;
-use warnings;
-
-use Getopt::Long;
-use File::Find 'find';
-use File::Basename 'basename';
-use File::Glob 'bsd_glob';
-
-sub read_file {
- my $f = shift;
- open my $fh, "<", $f or die "FATAL: read_rawfile() cannot open file '$f': $!";
- binmode $fh;
- return do { local $/; <$fh> };
-}
-
-sub write_file {
- my ($f, $data) = @_;
- die "FATAL: write_file() no data" unless defined $data;
- open my $fh, ">", $f or die "FATAL: write_file() cannot open file '$f': $!";
- binmode $fh;
- print $fh $data or die "FATAL: write_file() cannot write to '$f': $!";
- close $fh or die "FATAL: write_file() cannot close '$f': $!";
- return;
-}
-
-sub sanitize_comments {
- my($content) = @_;
- $content =~ s{/\*(.*?)\*/}{my $x=$1; $x =~ s/\w/x/g; "/*$x*/";}egs;
- return $content;
-}
-
-sub check_source {
- my @all_files = (
- bsd_glob("makefile*"),
- bsd_glob("*.{h,c,sh,pl}"),
- bsd_glob("*/*.{h,c,sh,pl}"),
- );
-
- my $fails = 0;
- for my $file (sort @all_files) {
- my $troubles = {};
- my $lineno = 1;
- my $content = read_file($file);
- $content = sanitize_comments $content;
- push @{$troubles->{crlf_line_end}}, '?' if $content =~ /\r/;
- for my $l (split /\n/, $content) {
- push @{$troubles->{merge_conflict}}, $lineno if $l =~ /^(<<<<<<<|=======|>>>>>>>)([^<=>]|$)/;
- push @{$troubles->{trailing_space}}, $lineno if $l =~ / $/;
- push @{$troubles->{tab}}, $lineno if $l =~ /\t/ && basename($file) !~ /^makefile/i;
- push @{$troubles->{non_ascii_char}}, $lineno if $l =~ /[^[:ascii:]]/;
- push @{$troubles->{cpp_comment}}, $lineno if $file =~ /\.(c|h)$/ && ($l =~ /\s\/\// || $l =~ /\/\/\s/);
- # we prefer using MP_MALLOC, MP_FREE, MP_REALLOC, MP_CALLOC ...
- push @{$troubles->{unwanted_malloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmalloc\s*\(/;
- push @{$troubles->{unwanted_realloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\brealloc\s*\(/;
- push @{$troubles->{unwanted_calloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bcalloc\s*\(/;
- push @{$troubles->{unwanted_free}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bfree\s*\(/;
- # and we probably want to also avoid the following
- push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/;
- push @{$troubles->{unwanted_memset}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemset\s*\(/;
- push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/;
- push @{$troubles->{unwanted_memmove}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemmove\s*\(/;
- push @{$troubles->{unwanted_memcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcmp\s*\(/;
- push @{$troubles->{unwanted_strcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcmp\s*\(/;
- push @{$troubles->{unwanted_strcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcpy\s*\(/;
- push @{$troubles->{unwanted_strncpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrncpy\s*\(/;
- push @{$troubles->{unwanted_clock}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bclock\s*\(/;
- push @{$troubles->{unwanted_qsort}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bqsort\s*\(/;
- push @{$troubles->{sizeof_no_brackets}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bsizeof\s*[^\(]/;
- if ($file =~ m|^[^\/]+\.c$| && $l =~ /^static(\s+[a-zA-Z0-9_]+)+\s+([a-zA-Z0-9_]+)\s*\(/) {
- my $funcname = $2;
- # static functions should start with s_
- push @{$troubles->{staticfunc_name}}, "$lineno($funcname)" if $funcname !~ /^s_/;
- }
- $lineno++;
- }
- for my $k (sort keys %$troubles) {
- warn "[$k] $file line:" . join(",", @{$troubles->{$k}}) . "\n";
- $fails++;
- }
- }
-
- warn( $fails > 0 ? "check-source: FAIL $fails\n" : "check-source: PASS\n" );
- return $fails;
-}
-
-sub check_comments {
- my $fails = 0;
- my $first_comment = <<'MARKER';
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
-MARKER
- #my @all_files = (bsd_glob("*.{h,c}"), bsd_glob("*/*.{h,c}"));
- my @all_files = (bsd_glob("*.{h,c}"));
- for my $f (@all_files) {
- my $txt = read_file($f);
- if ($txt !~ /\Q$first_comment\E/s) {
- warn "[first_comment] $f\n";
- $fails++;
- }
- }
- warn( $fails > 0 ? "check-comments: FAIL $fails\n" : "check-comments: PASS\n" );
- return $fails;
-}
-
-sub check_doc {
- my $fails = 0;
- my $tex = read_file('doc/bn.tex');
- my $tmh = read_file('tommath.h');
- my @functions = $tmh =~ /\n\s*[a-zA-Z0-9_* ]+?(mp_[a-z0-9_]+)\s*\([^\)]+\)\s*;/sg;
- my @macros = $tmh =~ /\n\s*#define\s+([a-z0-9_]+)\s*\([^\)]+\)/sg;
- for my $n (sort @functions) {
- (my $nn = $n) =~ s/_/\\_/g; # mp_sub_d >> mp\_sub\_d
- if ($tex !~ /index\Q{$nn}\E/) {
- warn "[missing_doc_for_function] $n\n";
- $fails++
- }
- }
- for my $n (sort @macros) {
- (my $nn = $n) =~ s/_/\\_/g; # mp_iszero >> mp\_iszero
- if ($tex !~ /index\Q{$nn}\E/) {
- warn "[missing_doc_for_macro] $n\n";
- $fails++
- }
- }
- warn( $fails > 0 ? "check_doc: FAIL $fails\n" : "check-doc: PASS\n" );
- return $fails;
-}
-
-sub prepare_variable {
- my ($varname, @list) = @_;
- my $output = "$varname=";
- my $len = length($output);
- foreach my $obj (sort @list) {
- $len = $len + length $obj;
- $obj =~ s/\*/\$/;
- if ($len > 100) {
- $output .= "\\\n";
- $len = length $obj;
- }
- $output .= $obj . ' ';
- }
- $output =~ s/ $//;
- return $output;
-}
-
-sub prepare_msvc_files_xml {
- my ($all, $exclude_re, $targets) = @_;
- my $last = [];
- my $depth = 2;
-
- # sort files in the same order as visual studio (ugly, I know)
- my @parts = ();
- for my $orig (@$all) {
- my $p = $orig;
- $p =~ s|/|/~|g;
- $p =~ s|/~([^/]+)$|/$1|g;
- my @l = map { sprintf "% -99s", $_ } split /\//, $p;
- push @parts, [ $orig, join(':', @l) ];
- }
- my @sorted = map { $_->[0] } sort { $a->[1] cmp $b->[1] } @parts;
-
- my $files = "\r\n";
- for my $full (@sorted) {
- my @items = split /\//, $full; # split by '/'
- $full =~ s|/|\\|g; # replace '/' bt '\'
- shift @items; # drop first one (src)
- pop @items; # drop last one (filename.ext)
- my $current = \@items;
- if (join(':', @$current) ne join(':', @$last)) {
- my $common = 0;
- $common++ while ($last->[$common] && $current->[$common] && $last->[$common] eq $current->[$common]);
- my $back = @$last - $common;
- if ($back > 0) {
- $files .= ("\t" x --$depth) . "\r\n" for (1..$back);
- }
- my $fwd = [ @$current ]; splice(@$fwd, 0, $common);
- for my $i (0..scalar(@$fwd) - 1) {
- $files .= ("\t" x $depth) . "[$i]\"\r\n";
- $files .= ("\t" x $depth) . "\t>\r\n";
- $depth++;
- }
- $last = $current;
- }
- $files .= ("\t" x $depth) . "\r\n";
- if ($full =~ $exclude_re) {
- for (@$targets) {
- $files .= ("\t" x $depth) . "\t\r\n";
- $files .= ("\t" x $depth) . "\t\t\r\n";
- $files .= ("\t" x $depth) . "\t\r\n";
- }
- }
- $files .= ("\t" x $depth) . "\r\n";
- }
- $files .= ("\t" x --$depth) . "\r\n" for (@$last);
- $files .= "\t";
- return $files;
-}
-
-sub patch_file {
- my ($content, @variables) = @_;
- for my $v (@variables) {
- if ($v =~ /^([A-Z0-9_]+)\s*=.*$/si) {
- my $name = $1;
- $content =~ s/\n\Q$name\E\b.*?[^\\]\n/\n$v\n/s;
- }
- else {
- die "patch_file failed: " . substr($v, 0, 30) . "..";
- }
- }
- return $content;
-}
-
-sub make_sources_cmake {
- my ($src_ref, $hdr_ref) = @_;
- my @sources = @{ $src_ref };
- my @headers = @{ $hdr_ref };
- my $output = "# SPDX-License-Identifier: Unlicense
-# Autogenerated File! Do not edit.
-
-set(SOURCES\n";
- foreach my $sobj (sort @sources) {
- $output .= $sobj . "\n";
- }
- $output .= ")\n\nset(HEADERS\n";
- foreach my $hobj (sort @headers) {
- $output .= $hobj . "\n";
- }
- $output .= ")\n";
- return $output;
-}
-
-sub process_makefiles {
- my $write = shift;
- my $changed_count = 0;
- my @headers = bsd_glob("*.h");
- my @sources = bsd_glob("*.c");
- my @o = map { my $x = $_; $x =~ s/\.c$/.o/; $x } @sources;
- my @all = sort(@sources, @headers);
-
- my $var_o = prepare_variable("OBJECTS", @o);
- (my $var_obj = $var_o) =~ s/\.o\b/.obj/sg;
-
- # update MSVC project files
- my $msvc_files = prepare_msvc_files_xml(\@all, qr/NOT_USED_HERE/, ['Debug|Win32', 'Release|Win32', 'Debug|x64', 'Release|x64']);
- for my $m (qw/libtommath_VS2008.vcproj/) {
- my $old = read_file($m);
- my $new = $old;
- $new =~ s|.*|$msvc_files|s;
- if ($old ne $new) {
- write_file($m, $new) if $write;
- warn "changed: $m\n";
- $changed_count++;
- }
- }
-
- # update OBJECTS + HEADERS in makefile*
- for my $m (qw/ makefile makefile.shared makefile_include.mk makefile.msvc makefile.unix makefile.mingw sources.cmake /) {
- my $old = read_file($m);
- my $new = $m eq 'makefile.msvc' ? patch_file($old, $var_obj)
- : $m eq 'sources.cmake' ? make_sources_cmake(\@sources, \@headers)
- : patch_file($old, $var_o);
-
- if ($old ne $new) {
- write_file($m, $new) if $write;
- warn "changed: $m\n";
- $changed_count++;
- }
- }
-
- if ($write) {
- return 0; # no failures
- }
- else {
- warn( $changed_count > 0 ? "check-makefiles: FAIL $changed_count\n" : "check-makefiles: PASS\n" );
- return $changed_count;
- }
-}
-
-sub draw_func
-{
- my ($deplist, $depmap, $out, $indent, $funcslist) = @_;
- my @funcs = split ',', $funcslist;
- # try this if you want to have a look at a minimized version of the callgraph without all the trivial functions
- #if ($deplist =~ /$funcs[0]/ || $funcs[0] =~ /BN_MP_(ADD|SUB|CLEAR|CLEAR_\S+|DIV|MUL|COPY|ZERO|GROW|CLAMP|INIT|INIT_\S+|SET|ABS|CMP|CMP_D|EXCH)_C/) {
- if ($deplist =~ /$funcs[0]/) {
- return $deplist;
- } else {
- $deplist = $deplist . $funcs[0];
- }
- if ($indent == 0) {
- } elsif ($indent >= 1) {
- print {$out} '| ' x ($indent - 1) . '+--->';
- }
- print {$out} $funcs[0] . "\n";
- shift @funcs;
- my $olddeplist = $deplist;
- foreach my $i (@funcs) {
- $deplist = draw_func($deplist, $depmap, $out, $indent + 1, ${$depmap}{$i}) if exists ${$depmap}{$i};
- }
- return $olddeplist;
-}
-
-sub update_dep
-{
- #open class file and write preamble
- open(my $class, '>', 'tommath_class.h') or die "Couldn't open tommath_class.h for writing\n";
- print {$class} << 'EOS';
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
-
-#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))
-#define LTM_INSIDE
-#if defined(LTM2)
-# define LTM3
-#endif
-#if defined(LTM1)
-# define LTM2
-#endif
-#define LTM1
-#if defined(LTM_ALL)
-EOS
-
- foreach my $filename (glob 'bn*.c') {
- my $define = $filename;
-
- print "Processing $filename\n";
-
- # convert filename to upper case so we can use it as a define
- $define =~ tr/[a-z]/[A-Z]/;
- $define =~ tr/\./_/;
- print {$class} "# define $define\n";
-
- # now copy text and apply #ifdef as required
- my $apply = 0;
- open(my $src, '<', $filename);
- open(my $out, '>', 'tmp');
-
- # first line will be the #ifdef
- my $line = <$src>;
- if ($line =~ /include/) {
- print {$out} $line;
- } else {
- print {$out} << "EOS";
-#include "tommath_private.h"
-#ifdef $define
-/* LibTomMath, multiple-precision integer library -- Tom St Denis */
-/* SPDX-License-Identifier: Unlicense */
-$line
-EOS
- $apply = 1;
- }
- while (<$src>) {
- if ($_ !~ /tommath\.h/) {
- print {$out} $_;
- }
- }
- if ($apply == 1) {
- print {$out} "#endif\n";
- }
- close $src;
- close $out;
-
- unlink $filename;
- rename 'tmp', $filename;
- }
- print {$class} "#endif\n#endif\n";
-
- # now do classes
- my %depmap;
- foreach my $filename (glob 'bn*.c') {
- my $content;
- if ($filename =~ "bn_deprecated.c") {
- open(my $src, '<', $filename) or die "Can't open source file!\n";
- read $src, $content, -s $src;
- close $src;
- } else {
- my $cc = $ENV{'CC'} || 'gcc';
- $content = `$cc -E -x c -DLTM_ALL $filename`;
- $content =~ s/^# 1 "$filename".*?^# 2 "$filename"//ms;
- }
-
- # convert filename to upper case so we can use it as a define
- $filename =~ tr/[a-z]/[A-Z]/;
- $filename =~ tr/\./_/;
-
- print {$class} "#if defined($filename)\n";
- my $list = $filename;
-
- # strip comments
- $content =~ s{/\*.*?\*/}{}gs;
-
- # scan for mp_* and make classes
- my @deps = ();
- foreach my $line (split /\n/, $content) {
- while ($line =~ /(fast_)?(s_)?mp\_[a-z_0-9]*((?=\;)|(?=\())|(?<=\()mp\_[a-z_0-9]*(?=\()/g) {
- my $a = $&;
- next if $a eq "mp_err";
- $a =~ tr/[a-z]/[A-Z]/;
- $a = 'BN_' . $a . '_C';
- push @deps, $a;
- }
- }
- if ($filename =~ "BN_DEPRECATED") {
- push(@deps, qw(BN_MP_GET_LL_C BN_MP_INIT_LL_C BN_MP_SET_LL_C));
- push(@deps, qw(BN_MP_GET_MAG_ULL_C BN_MP_INIT_ULL_C BN_MP_SET_ULL_C));
- push(@deps, qw(BN_MP_DIV_3_C BN_MP_EXPT_U32_C BN_MP_ROOT_U32_C BN_MP_LOG_U32_C));
- }
- @deps = sort(@deps);
- foreach my $a (@deps) {
- if ($list !~ /$a/) {
- print {$class} "# define $a\n";
- }
- $list = $list . ',' . $a;
- }
- $depmap{$filename} = $list;
-
- print {$class} "#endif\n\n";
- }
-
- print {$class} << 'EOS';
-#ifdef LTM_INSIDE
-#undef LTM_INSIDE
-#ifdef LTM3
-# define LTM_LAST
-#endif
-
-#include "tommath_superclass.h"
-#include "tommath_class.h"
-#else
-# define LTM_LAST
-#endif
-EOS
- close $class;
-
- #now let's make a cool call graph...
-
- open(my $out, '>', 'callgraph.txt');
- foreach (sort keys %depmap) {
- draw_func("", \%depmap, $out, 0, $depmap{$_});
- print {$out} "\n\n";
- }
- close $out;
-
- return 0;
-}
-
-sub generate_def {
- my @files = split /\n/, `git ls-files`;
- @files = grep(/\.c/, @files);
- @files = map { my $x = $_; $x =~ s/^bn_|\.c$//g; $x; } @files;
- @files = grep(!/mp_radix_smap/, @files);
-
- push(@files, qw(mp_set_int mp_set_long mp_set_long_long mp_get_int mp_get_long mp_get_long_long mp_init_set_int));
- push(@files, qw(mp_get_ll mp_get_mag_ull mp_init_ll mp_set_ll mp_init_ull mp_set_ull));
- push(@files, qw(mp_div_3 mp_expt_u32 mp_root_u32 mp_log_u32));
-
- my $files = join("\n ", sort(grep(/^mp_/, @files)));
- write_file "tommath.def", "; libtommath
-;
-; Use this command to produce a 32-bit .lib file, for use in any MSVC version
-; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib
-; Use this command to produce a 64-bit .lib file, for use in any MSVC version
-; lib -machine:X64 -name:libtommath.dll -def:tommath.def -out:tommath.lib
-;
-EXPORTS
- $files
-";
- return 0;
-}
-
-sub die_usage {
- die <<"MARKER";
-usage: $0 -s OR $0 --check-source
- $0 -o OR $0 --check-comments
- $0 -m OR $0 --check-makefiles
- $0 -a OR $0 --check-all
- $0 -u OR $0 --update-files
-MARKER
-}
-
-GetOptions( "s|check-source" => \my $check_source,
- "o|check-comments" => \my $check_comments,
- "m|check-makefiles" => \my $check_makefiles,
- "d|check-doc" => \my $check_doc,
- "a|check-all" => \my $check_all,
- "u|update-files" => \my $update_files,
- "h|help" => \my $help
- ) or die_usage;
-
-my $failure;
-$failure ||= check_source() if $check_all || $check_source;
-$failure ||= check_comments() if $check_all || $check_comments;
-$failure ||= check_doc() if $check_doc; # temporarily excluded from --check-all
-$failure ||= process_makefiles(0) if $check_all || $check_makefiles;
-$failure ||= process_makefiles(1) if $update_files;
-$failure ||= update_dep() if $update_files;
-$failure ||= generate_def() if $update_files;
-
-die_usage unless defined $failure;
-exit $failure ? 1 : 0;
DELETED libtommath/libtommath_VS2008.sln
Index: libtommath/libtommath_VS2008.sln
==================================================================
--- libtommath/libtommath_VS2008.sln
+++ /dev/null
@@ -1,29 +0,0 @@
-
-Microsoft Visual Studio Solution File, Format Version 10.00
-# Visual Studio 2008
-Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "tommath", "libtommath_VS2008.vcproj", "{42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}"
-EndProject
-Global
- GlobalSection(SolutionConfigurationPlatforms) = preSolution
- Debug|Win32 = Debug|Win32
- Debug|x64 = Debug|x64
- Release|Win32 = Release|Win32
- Release|x64 = Release|x64
- EndGlobalSection
- GlobalSection(ProjectConfigurationPlatforms) = postSolution
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.ActiveCfg = Debug|Win32
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|Win32.Build.0 = Debug|Win32
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|x64.ActiveCfg = Debug|x64
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Debug|x64.Build.0 = Debug|x64
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.ActiveCfg = Release|Win32
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|Win32.Build.0 = Release|Win32
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|x64.ActiveCfg = Release|x64
- {42109FEE-B0B9-4FCD-9E56-2863BF8C55D2}.Release|x64.Build.0 = Release|x64
- EndGlobalSection
- GlobalSection(SolutionProperties) = preSolution
- HideSolutionNode = FALSE
- EndGlobalSection
- GlobalSection(ExtensibilityGlobals) = postSolution
- SolutionGuid = {83B84178-7B4F-4B78-9C5D-17B8201D5B61}
- EndGlobalSection
-EndGlobal
DELETED libtommath/libtommath_VS2008.vcproj
Index: libtommath/libtommath_VS2008.vcproj
==================================================================
--- libtommath/libtommath_VS2008.vcproj
+++ /dev/null
@@ -1,954 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
DELETED libtommath/makefile
Index: libtommath/makefile
==================================================================
--- libtommath/makefile
+++ /dev/null
@@ -1,169 +0,0 @@
-#Makefile for GCC
-#
-#Tom St Denis
-
-ifeq ($V,1)
-silent=
-else
-silent=@
-endif
-
-#default files to install
-ifndef LIBNAME
- LIBNAME=libtommath.a
-endif
-
-coverage: LIBNAME:=-Wl,--whole-archive $(LIBNAME) -Wl,--no-whole-archive
-
-include makefile_include.mk
-
-%.o: %.c $(HEADERS)
-ifneq ($V,1)
- @echo " * ${CC} $@"
-endif
- ${silent} ${CC} -c ${LTM_CFLAGS} $< -o $@
-
-LCOV_ARGS=--directory .
-
-#START_INS
-OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
-bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
-bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
-bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
-bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
-bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
-bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \
-bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \
-bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \
-bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \
-bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \
-bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \
-bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \
-bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \
-bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \
-bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \
-bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
-bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \
-bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \
-bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \
-bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \
-bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \
-bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \
-bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \
-bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \
-bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \
-bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \
-bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \
-bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
-
-#END_INS
-
-$(LIBNAME): $(OBJECTS)
- $(AR) $(ARFLAGS) $@ $(OBJECTS)
- $(RANLIB) $@
-
-#make a profiled library (takes a while!!!)
-#
-# This will build the library with profile generation
-# then run the test demo and rebuild the library.
-#
-# So far I've seen improvements in the MP math
-profiled:
- make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing
- ./timing
- rm -f *.a *.o timing
- make CFLAGS="$(CFLAGS) -fbranch-probabilities"
-
-#make a single object profiled library
-profiled_single:
- perl gen.pl
- $(CC) $(LTM_CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o
- $(CC) $(LTM_CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -lgcov -o timing
- ./timing
- rm -f *.o timing
- $(CC) $(LTM_CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o
- $(AR) $(ARFLAGS) $(LIBNAME) mpi.o
- ranlib $(LIBNAME)
-
-install: $(LIBNAME)
- install -d $(DESTDIR)$(LIBPATH)
- install -d $(DESTDIR)$(INCPATH)
- install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)
- install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH)
-
-uninstall:
- rm $(DESTDIR)$(LIBPATH)/$(LIBNAME)
- rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%)
-
-test_standalone: test
- @echo "test_standalone is deprecated, please use make-target 'test'"
-
-DEMOS=test mtest_opponent
-
-define DEMO_template
-$(1): demo/$(1).o demo/shared.o $$(LIBNAME)
- $$(CC) $$(LTM_CFLAGS) $$(LTM_LFLAGS) $$^ -o $$@
-endef
-
-$(foreach demo, $(strip $(DEMOS)), $(eval $(call DEMO_template,$(demo))))
-
-.PHONY: mtest
-mtest:
- cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LFLAGS) -o mtest
-
-timing: $(LIBNAME) demo/timing.c
- $(CC) $(LTM_CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LTM_LFLAGS) -o timing
-
-tune: $(LIBNAME)
- $(MAKE) -C etc tune CFLAGS="$(LTM_CFLAGS)"
- $(MAKE)
-
-# You have to create a file .coveralls.yml with the content "repo_token: "
-# in the base folder to be able to submit to coveralls
-coveralls: lcov
- coveralls-lcov
-
-docs manual:
- $(MAKE) -C doc/ $@ V=$(V)
-
-.PHONY: pre_gen
-pre_gen:
- mkdir -p pre_gen
- perl gen.pl
- sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c
- rm mpi.c
-
-zipup:
- $(MAKE) clean
- $(MAKE) .zipup
-
-.zipup: astyle new_file docs
- @# Update the index, so diff-index won't fail in case the pdf has been created.
- @# As the pdf creation modifies the tex files, git sometimes detects the
- @# modified files, but misses that it's put back to its original version.
- @git update-index --refresh
- @git diff-index --quiet HEAD -- || ( echo "FAILURE: uncommited changes or not a git" && exit 1 )
- rm -rf libtommath-$(VERSION) ltm-$(VERSION).*
- @# files/dirs excluded from "git archive" are defined in .gitattributes
- git archive --format=tar --prefix=libtommath-$(VERSION)/ HEAD | tar x
- @echo 'fixme check'
- -@(find libtommath-$(VERSION)/ -type f | xargs grep 'FIXM[E]') && echo '############## BEWARE: the "fixme" marker was found !!! ##############' || true
- mkdir -p libtommath-$(VERSION)/doc
- cp doc/bn.pdf libtommath-$(VERSION)/doc/
- $(MAKE) -C libtommath-$(VERSION)/ pre_gen
- tar -c libtommath-$(VERSION)/ | xz -6e -c - > ltm-$(VERSION).tar.xz
- zip -9rq ltm-$(VERSION).zip libtommath-$(VERSION)
- cp doc/bn.pdf bn-$(VERSION).pdf
- rm -rf libtommath-$(VERSION)
- gpg -b -a ltm-$(VERSION).tar.xz
- gpg -b -a ltm-$(VERSION).zip
-
-new_file:
- perl helper.pl --update-files
-
-perlcritic:
- perlcritic *.pl doc/*.pl
-
-astyle:
- @echo " * run astyle on all sources"
- @astyle --options=astylerc --formatted $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c
DELETED libtommath/makefile.mingw
Index: libtommath/makefile.mingw
==================================================================
--- libtommath/makefile.mingw
+++ /dev/null
@@ -1,113 +0,0 @@
-# MAKEFILE for MS Windows (mingw + gcc + gmake)
-#
-# BEWARE: variable OBJECTS is updated via helper.pl
-
-### USAGE:
-# Open a command prompt with gcc + gmake in PATH and start:
-#
-# gmake -f makefile.mingw all
-# test.exe
-# gmake -f makefile.mingw PREFIX=c:\devel\libtom install
-
-#The following can be overridden from command line e.g. make -f makefile.mingw CC=gcc ARFLAGS=rcs
-PREFIX = c:\mingw
-CC = i686-w64-mingw32-gcc
-#CC = x86_64-w64-mingw32-clang
-#CC = aarch64-w64-mingw32-clang
-AR = ar
-ARFLAGS = r
-RANLIB = ranlib
-STRIP = i686-w64-mingw32-gcc-strip
-#STRIP = x86_64-w64-mingw32-strip
-#STRIP = aarch64-w64-mingw32-strip
-CFLAGS = -O2
-LDFLAGS =
-
-#Compilation flags
-LTM_CFLAGS = -I. $(CFLAGS) -DTCL_WITH_EXTERNAL_TOMMATH
-LTM_LDFLAGS = $(LDFLAGS) -static-libgcc
-
-#Libraries to be created
-LIBMAIN_S =libtommath.a
-LIBMAIN_I =libtommath.dll.a
-LIBMAIN_D =libtommath.dll
-
-#List of objects to compile (all goes to libtommath.a)
-OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
-bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
-bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
-bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
-bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
-bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
-bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \
-bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \
-bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \
-bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \
-bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \
-bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \
-bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \
-bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \
-bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \
-bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \
-bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
-bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \
-bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \
-bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \
-bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \
-bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \
-bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \
-bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \
-bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \
-bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \
-bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \
-bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \
-bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
-
-HEADERS_PUB=tommath.h
-HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB)
-
-#The default rule for make builds the libtommath.a library (static)
-default: $(LIBMAIN_S)
-
-#Dependencies on *.h
-$(OBJECTS): $(HEADERS)
-
-.c.o:
- $(CC) $(LTM_CFLAGS) -c $< -o $@
-
-#Create libtommath.a
-$(LIBMAIN_S): $(OBJECTS)
- $(AR) $(ARFLAGS) $@ $(OBJECTS)
- $(RANLIB) $@
-
-#Create DLL + import library libtommath.dll.a
-$(LIBMAIN_D) $(LIBMAIN_I): $(OBJECTS)
- $(CC) -s -shared -o $(LIBMAIN_D) $^ -Wl,--enable-auto-import tommath.def -Wl,--out-implib=$(LIBMAIN_I) $(LTM_LDFLAGS)
- $(STRIP) -S $(LIBMAIN_D)
-
-#Build test suite
-test.exe: demo/shared.o demo/test.o $(LIBMAIN_S)
- $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@
- @echo NOTICE: start the tests by launching test.exe
-
-test_standalone: test.exe
- @echo test_standalone is deprecated, please use make-target 'test.exe'
-
-all: $(LIBMAIN_S) test.exe
-
-tune: $(LIBNAME_S)
- $(MAKE) -C etc tune
- $(MAKE)
-
-clean:
- @-cmd /c del /Q /S *.o *.a *.exe *.dll 2>nul
-
-#Install the library + headers
-install: $(LIBMAIN_S) $(LIBMAIN_I) $(LIBMAIN_D)
- cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin"
- cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib"
- cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include"
- copy /Y $(LIBMAIN_S) "$(PREFIX)\lib"
- copy /Y $(LIBMAIN_I) "$(PREFIX)\lib"
- copy /Y $(LIBMAIN_D) "$(PREFIX)\bin"
- copy /Y tommath*.h "$(PREFIX)\include"
DELETED libtommath/makefile.msvc
Index: libtommath/makefile.msvc
==================================================================
--- libtommath/makefile.msvc
+++ /dev/null
@@ -1,93 +0,0 @@
-# MAKEFILE for MS Windows (nmake + Windows SDK)
-#
-# BEWARE: variable OBJECTS is updated via helper.pl
-
-### USAGE:
-# Open a command prompt with WinSDK variables set and start:
-#
-# nmake -f makefile.msvc all
-# test.exe
-# nmake -f makefile.msvc PREFIX=c:\devel\libtom install
-
-#The following can be overridden from command line e.g. make -f makefile.msvc CC=gcc ARFLAGS=rcs
-PREFIX = c:\devel
-CFLAGS = /Ox
-
-#Compilation flags
-LTM_CFLAGS = /nologo /I./ /D_CRT_SECURE_NO_WARNINGS /D_CRT_NONSTDC_NO_DEPRECATE /D__STDC_WANT_SECURE_LIB__=1 /D_CRT_HAS_CXX17=0 /Wall /wd4146 /wd4127 /wd4668 /wd4710 /wd4711 /wd4820 /wd5045 /WX $(CFLAGS)
-LTM_LDFLAGS = advapi32.lib
-
-#Libraries to be created (this makefile builds only static libraries)
-LIBMAIN_S =tommath.lib
-
-#List of objects to compile (all goes to tommath.lib)
-OBJECTS=bn_cutoffs.obj bn_deprecated.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj bn_mp_addmod.obj \
-bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj bn_mp_cmp_mag.obj \
-bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_decr.obj bn_mp_div.obj bn_mp_div_2.obj \
-bn_mp_div_2d.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj bn_mp_dr_setup.obj \
-bn_mp_error_to_string.obj bn_mp_exch.obj bn_mp_expt_n.obj bn_mp_exptmod.obj bn_mp_exteuclid.obj bn_mp_fread.obj \
-bn_mp_from_sbin.obj bn_mp_from_ubin.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_double.obj bn_mp_get_i32.obj \
-bn_mp_get_i64.obj bn_mp_get_l.obj bn_mp_get_mag_u32.obj bn_mp_get_mag_u64.obj bn_mp_get_mag_ul.obj bn_mp_grow.obj \
-bn_mp_incr.obj bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_i32.obj bn_mp_init_i64.obj bn_mp_init_l.obj \
-bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_size.obj bn_mp_init_u32.obj bn_mp_init_u64.obj bn_mp_init_ul.obj \
-bn_mp_invmod.obj bn_mp_is_square.obj bn_mp_iseven.obj bn_mp_isodd.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_log_n.obj \
-bn_mp_lshd.obj bn_mp_mod.obj bn_mp_mod_2d.obj bn_mp_mod_d.obj bn_mp_montgomery_calc_normalization.obj \
-bn_mp_montgomery_reduce.obj bn_mp_montgomery_setup.obj bn_mp_mul.obj bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj \
-bn_mp_mulmod.obj bn_mp_neg.obj bn_mp_or.obj bn_mp_pack.obj bn_mp_pack_count.obj bn_mp_prime_fermat.obj \
-bn_mp_prime_frobenius_underwood.obj bn_mp_prime_is_prime.obj bn_mp_prime_miller_rabin.obj \
-bn_mp_prime_next_prime.obj bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_rand.obj \
-bn_mp_prime_strong_lucas_selfridge.obj bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj \
-bn_mp_read_radix.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj \
-bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj \
-bn_mp_root_n.obj bn_mp_rshd.obj bn_mp_sbin_size.obj bn_mp_set.obj bn_mp_set_double.obj bn_mp_set_i32.obj \
-bn_mp_set_i64.obj bn_mp_set_l.obj bn_mp_set_u32.obj bn_mp_set_u64.obj bn_mp_set_ul.obj bn_mp_shrink.obj \
-bn_mp_signed_rsh.obj bn_mp_sqr.obj bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj bn_mp_sub_d.obj \
-bn_mp_submod.obj bn_mp_to_radix.obj bn_mp_to_sbin.obj bn_mp_to_ubin.obj bn_mp_ubin_size.obj bn_mp_unpack.obj \
-bn_mp_xor.obj bn_mp_zero.obj bn_prime_tab.obj bn_s_mp_add.obj bn_s_mp_balance_mul.obj bn_s_mp_div_3.obj \
-bn_s_mp_exptmod.obj bn_s_mp_exptmod_fast.obj bn_s_mp_get_bit.obj bn_s_mp_invmod_fast.obj bn_s_mp_invmod_slow.obj \
-bn_s_mp_karatsuba_mul.obj bn_s_mp_karatsuba_sqr.obj bn_s_mp_log.obj bn_s_mp_log_2expt.obj bn_s_mp_log_d.obj \
-bn_s_mp_montgomery_reduce_fast.obj bn_s_mp_mul_digs.obj bn_s_mp_mul_digs_fast.obj bn_s_mp_mul_high_digs.obj \
-bn_s_mp_mul_high_digs_fast.obj bn_s_mp_prime_is_divisible.obj bn_s_mp_rand_jenkins.obj \
-bn_s_mp_rand_platform.obj bn_s_mp_reverse.obj bn_s_mp_sqr.obj bn_s_mp_sqr_fast.obj bn_s_mp_sub.obj \
-bn_s_mp_toom_mul.obj bn_s_mp_toom_sqr.obj
-
-HEADERS_PUB=tommath.h
-HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB)
-
-#The default rule for make builds the tommath.lib library (static)
-default: $(LIBMAIN_S)
-
-#Dependencies on *.h
-$(OBJECTS): $(HEADERS)
-
-.c.obj:
- $(CC) $(LTM_CFLAGS) /c $< /Fo$@
-
-#Create tommath.lib
-$(LIBMAIN_S): $(OBJECTS)
- lib /out:$(LIBMAIN_S) $(OBJECTS)
-
-#Build test suite
-test.exe: $(LIBMAIN_S) demo/shared.obj demo/test.obj
- cl $(LTM_CFLAGS) $(TOBJECTS) $(LIBMAIN_S) $(LTM_LDFLAGS) demo/shared.c demo/test.c /Fe$@
- @echo NOTICE: start the tests by launching test.exe
-
-test_standalone: test.exe
- @echo test_standalone is deprecated, please use make-target 'test.exe'
-
-all: $(LIBMAIN_S) test.exe
-
-tune: $(LIBMAIN_S)
- $(MAKE) -C etc tune
- $(MAKE)
-
-clean:
- @-cmd /c del /Q /S *.OBJ *.LIB *.EXE *.DLL 2>nul
-
-#Install the library + headers
-install: $(LIBMAIN_S)
- cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin"
- cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib"
- cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include"
- copy /Y $(LIBMAIN_S) "$(PREFIX)\lib"
- copy /Y tommath*.h "$(PREFIX)\include"
DELETED libtommath/makefile.shared
Index: libtommath/makefile.shared
==================================================================
--- libtommath/makefile.shared
+++ /dev/null
@@ -1,100 +0,0 @@
-#Makefile for GCC
-#
-#Tom St Denis
-
-#default files to install
-ifndef LIBNAME
- LIBNAME=libtommath.la
-endif
-
-include makefile_include.mk
-
-
-ifndef LIBTOOL
- ifeq ($(PLATFORM), Darwin)
- LIBTOOL:=glibtool
- else
- LIBTOOL:=libtool
- endif
-endif
-LTCOMPILE = $(LIBTOOL) --mode=compile --tag=CC $(CC)
-LTLINK = $(LIBTOOL) --mode=link --tag=CC $(CC)
-
-LCOV_ARGS=--directory .libs --directory .
-
-#START_INS
-OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
-bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
-bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
-bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
-bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
-bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
-bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \
-bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \
-bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \
-bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \
-bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \
-bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \
-bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \
-bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \
-bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \
-bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \
-bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
-bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \
-bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \
-bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \
-bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \
-bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \
-bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \
-bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \
-bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \
-bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \
-bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \
-bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \
-bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
-
-#END_INS
-
-objs: $(OBJECTS)
-
-.c.o: $(HEADERS)
- $(LTCOMPILE) $(LTM_CFLAGS) $(LTM_LDFLAGS) -o $@ -c $<
-
-LOBJECTS = $(OBJECTS:.o=.lo)
-
-$(LIBNAME): $(OBJECTS)
- $(LTLINK) $(LTM_LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LTM_LIBTOOLFLAGS)
-
-install: $(LIBNAME)
- install -d $(DESTDIR)$(LIBPATH)
- install -d $(DESTDIR)$(INCPATH)
- $(LIBTOOL) --mode=install install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)/$(LIBNAME)
- install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH)
- sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION_PC),' -e 's,@CMAKE_INSTALL_LIBDIR@,lib,' \
- -e 's,@CMAKE_INSTALL_INCLUDEDIR@,include,' libtommath.pc.in > libtommath.pc
- install -d $(DESTDIR)$(LIBPATH)/pkgconfig
- install -m 644 libtommath.pc $(DESTDIR)$(LIBPATH)/pkgconfig/
-
-uninstall:
- $(LIBTOOL) --mode=uninstall rm $(DESTDIR)$(LIBPATH)/$(LIBNAME)
- rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%)
- rm $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc
-
-test_standalone: test
- @echo "test_standalone is deprecated, please use make-target 'test'"
-
-test mtest_opponent: demo/shared.o $(LIBNAME) | demo/test.o demo/mtest_opponent.o
- $(LTLINK) $(LTM_LDFLAGS) demo/$@.o $^ -o $@
-
-.PHONY: mtest
-mtest:
- cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LDFLAGS) -o mtest
-
-timing: $(LIBNAME) demo/timing.c
- $(LTLINK) $(LTM_CFLAGS) $(LTM_LDFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o timing
-
-tune: $(LIBNAME)
- $(LTCOMPILE) $(LTM_CFLAGS) -c etc/tune.c -o etc/tune.o
- $(LTLINK) $(LTM_LDFLAGS) -o etc/tune etc/tune.o $(LIBNAME)
- cd etc/; /bin/sh tune_it.sh; cd ..
- $(MAKE) -f makefile.shared
DELETED libtommath/makefile.unix
Index: libtommath/makefile.unix
==================================================================
--- libtommath/makefile.unix
+++ /dev/null
@@ -1,106 +0,0 @@
-# MAKEFILE that is intended to be compatible with any kind of make (GNU make, BSD make, ...)
-# works on: Linux, *BSD, Cygwin, AIX, HP-UX and hopefully other UNIX systems
-#
-# Please do not use here neither any special make syntax nor any unusual tools/utilities!
-
-# using ICC compiler:
-# make -f makefile.unix CC=icc CFLAGS="-O3 -xP -ip"
-
-# using Borland C++Builder:
-# make -f makefile.unix CC=bcc32
-
-#The following can be overridden from command line e.g. "make -f makefile.unix CC=gcc ARFLAGS=rcs"
-DESTDIR =
-PREFIX = /usr/local
-LIBPATH = $(PREFIX)/lib
-INCPATH = $(PREFIX)/include
-CC = cc
-AR = ar
-ARFLAGS = r
-RANLIB = ranlib
-CFLAGS = -O2
-LDFLAGS =
-
-VERSION = 1.3.0
-
-#Compilation flags
-LTM_CFLAGS = -I. $(CFLAGS)
-LTM_LDFLAGS = $(LDFLAGS)
-
-#Library to be created (this makefile builds only static library)
-LIBMAIN_S = libtommath.a
-
-OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
-bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
-bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
-bn_mp_div_2d.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
-bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_n.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
-bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
-bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o bn_mp_grow.o \
-bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o bn_mp_init_i64.o bn_mp_init_l.o \
-bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o \
-bn_mp_invmod.o bn_mp_is_square.o bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_n.o \
-bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o \
-bn_mp_montgomery_reduce.o bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o \
-bn_mp_mulmod.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o \
-bn_mp_prime_frobenius_underwood.o bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o \
-bn_mp_prime_next_prime.o bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o \
-bn_mp_prime_strong_lucas_selfridge.o bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o \
-bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o \
-bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o \
-bn_mp_root_n.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o bn_mp_set_double.o bn_mp_set_i32.o \
-bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_u32.o bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_shrink.o \
-bn_mp_signed_rsh.o bn_mp_sqr.o bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o \
-bn_mp_submod.o bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o \
-bn_mp_xor.o bn_mp_zero.o bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_div_3.o \
-bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o \
-bn_s_mp_karatsuba_mul.o bn_s_mp_karatsuba_sqr.o bn_s_mp_log.o bn_s_mp_log_2expt.o bn_s_mp_log_d.o \
-bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o bn_s_mp_mul_high_digs.o \
-bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o bn_s_mp_rand_jenkins.o \
-bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o bn_s_mp_sub.o \
-bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
-
-HEADERS_PUB=tommath.h
-HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB)
-
-#The default rule for make builds the libtommath.a library (static)
-default: $(LIBMAIN_S)
-
-#Dependencies on *.h
-$(OBJECTS): $(HEADERS)
-
-#This is necessary for compatibility with BSD make (namely on OpenBSD)
-.SUFFIXES: .o .c
-.c.o:
- $(CC) $(LTM_CFLAGS) -c $< -o $@
-
-#Create libtommath.a
-$(LIBMAIN_S): $(OBJECTS)
- $(AR) $(ARFLAGS) $@ $(OBJECTS)
- $(RANLIB) $@
-
-#Build test_standalone suite
-test: demo/shared.o demo/test.o $(LIBMAIN_S)
- $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@
- @echo "NOTICE: start the tests by: ./test"
-
-test_standalone: test
- @echo "test_standalone is deprecated, please use make-target 'test'"
-
-all: $(LIBMAIN_S) test
-
-tune: $(LIBMAIN_S)
- $(MAKE) -C etc tune
- $(MAKE)
-
-#NOTE: this makefile works also on cygwin, thus we need to delete *.exe
-clean:
- -@rm -f $(OBJECTS) $(LIBMAIN_S)
- -@rm -f demo/main.o demo/opponent.o demo/test.o test test.exe
-
-#Install the library + headers
-install: $(LIBMAIN_S)
- @mkdir -p $(DESTDIR)$(INCPATH) $(DESTDIR)$(LIBPATH)/pkgconfig
- @cp $(LIBMAIN_S) $(DESTDIR)$(LIBPATH)/
- @cp $(HEADERS_PUB) $(DESTDIR)$(INCPATH)/
- @sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION),' libtommath.pc.in > $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc
DELETED libtommath/makefile_include.mk
Index: libtommath/makefile_include.mk
==================================================================
--- libtommath/makefile_include.mk
+++ /dev/null
@@ -1,166 +0,0 @@
-#
-# Include makefile for libtommath
-#
-
-#version of library
-VERSION=1.3.0
-VERSION_PC=1.3.0
-VERSION_SO=4:0:3
-
-PLATFORM := $(shell uname | sed -e 's/_.*//')
-
-# default make target
-default: ${LIBNAME}
-
-# Compiler and Linker Names
-ifndef CROSS_COMPILE
- CROSS_COMPILE=
-endif
-
-# We only need to go through this dance of determining the right compiler if we're using
-# cross compilation, otherwise $(CC) is fine as-is.
-ifneq (,$(CROSS_COMPILE))
-ifeq ($(origin CC),default)
-CSTR := "\#ifdef __clang__\nCLANG\n\#endif\n"
-ifeq ($(PLATFORM),FreeBSD)
- # XXX: FreeBSD needs extra escaping for some reason
- CSTR := $$$(CSTR)
-endif
-ifneq (,$(shell echo $(CSTR) | $(CC) -E - | grep CLANG))
- CC := $(CROSS_COMPILE)clang
-else
- CC := $(CROSS_COMPILE)gcc
-endif # Clang
-endif # cc is Make's default
-endif # CROSS_COMPILE non-empty
-
-LD=$(CROSS_COMPILE)ld
-AR=$(CROSS_COMPILE)ar
-RANLIB=$(CROSS_COMPILE)ranlib
-
-ifndef MAKE
-# BSDs refer to GNU Make as gmake
-ifneq (,$(findstring $(PLATFORM),FreeBSD OpenBSD DragonFly NetBSD))
- MAKE=gmake
-else
- MAKE=make
-endif
-endif
-
-LTM_CFLAGS += -I./ -Wall -Wsign-compare -Wextra -Wshadow
-
-ifdef SANITIZER
-LTM_CFLAGS += -fsanitize=undefined -fno-sanitize-recover=all -fno-sanitize=float-divide-by-zero
-endif
-
-ifndef NO_ADDTL_WARNINGS
-# additional warnings
-LTM_CFLAGS += -Wdeclaration-after-statement -Wbad-function-cast -Wcast-align
-LTM_CFLAGS += -Wstrict-prototypes -Wpointer-arith
-endif
-
-ifdef CONV_WARNINGS
-LTM_CFLAGS += -std=c89 -Wconversion -Wsign-conversion
-ifeq ($(CONV_WARNINGS), strict)
-LTM_CFLAGS += -DMP_USE_ENUMS -Wc++-compat
-endif
-else
-LTM_CFLAGS += -Wsystem-headers
-endif
-
-ifdef COMPILE_DEBUG
-#debug
-LTM_CFLAGS += -g3
-endif
-
-ifdef COMPILE_SIZE
-#for size
-LTM_CFLAGS += -Os
-else
-
-ifndef IGNORE_SPEED
-#for speed
-LTM_CFLAGS += -O3 -funroll-loops
-
-#x86 optimizations [should be valid for any GCC install though]
-LTM_CFLAGS += -fomit-frame-pointer
-endif
-
-endif # COMPILE_SIZE
-
-ifneq ($(findstring clang,$(CC)),)
-LTM_CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header
-endif
-ifneq ($(findstring mingw,$(CC)),)
-LTM_CFLAGS += -Wno-shadow
-endif
-ifeq ($(PLATFORM), Darwin)
-LTM_CFLAGS += -Wno-nullability-completeness
-endif
-ifeq ($(PLATFORM), CYGWIN)
-LIBTOOLFLAGS += -no-undefined
-endif
-
-# add in the standard FLAGS
-LTM_CFLAGS += $(CFLAGS)
-LTM_LFLAGS += $(LFLAGS)
-LTM_LDFLAGS += $(LDFLAGS)
-LTM_LIBTOOLFLAGS += $(LIBTOOLFLAGS)
-
-
-ifeq ($(PLATFORM),FreeBSD)
- _ARCH := $(shell sysctl -b hw.machine_arch)
-else
- _ARCH := $(shell uname -m)
-endif
-
-# adjust coverage set
-ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),)
- COVERAGE = test_standalone timing
- COVERAGE_APP = ./test && ./timing
-else
- COVERAGE = test_standalone
- COVERAGE_APP = ./test
-endif
-
-HEADERS_PUB=tommath.h
-HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB)
-
-#LIBPATH The directory for libtommath to be installed to.
-#INCPATH The directory to install the header files for libtommath.
-#DATAPATH The directory to install the pdf docs.
-DESTDIR ?=
-PREFIX ?= /usr/local
-LIBPATH ?= $(PREFIX)/lib
-INCPATH ?= $(PREFIX)/include
-DATAPATH ?= $(PREFIX)/share/doc/libtommath/pdf
-
-#make the code coverage of the library
-#
-coverage: LTM_CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS
-coverage: LTM_LFLAGS += -lgcov
-coverage: LTM_LDFLAGS += -lgcov
-
-coverage: $(COVERAGE)
- $(COVERAGE_APP)
-
-lcov: coverage
- rm -f coverage.info
- lcov --capture --no-external --no-recursion $(LCOV_ARGS) --output-file coverage.info -q
- genhtml coverage.info --output-directory coverage -q
-
-# target that removes all coverage output
-cleancov-clean:
- rm -f `find . -type f -name "*.info" | xargs`
- rm -rf coverage/
-
-# cleans everything - coverage output and standard 'clean'
-cleancov: cleancov-clean clean
-
-clean:
- rm -f *.gcda *.gcno *.gcov *.bat *.o *.a *.obj *.lib *.exe *.dll etclib/*.o \
- demo/*.o test timing mtest_opponent mtest/mtest mtest/mtest.exe tuning_list \
- *.s mpi.c *.da *.dyn *.dpi tommath.tex `find . -type f | grep [~] | xargs` *.lo *.la
- rm -rf .libs/ demo/.libs
- ${MAKE} -C etc/ clean MAKE=${MAKE}
- ${MAKE} -C doc/ clean MAKE=${MAKE}
DELETED libtommath/win32/libtommath.dll
Index: libtommath/win32/libtommath.dll
==================================================================
--- libtommath/win32/libtommath.dll
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win32/tommath.lib
Index: libtommath/win32/tommath.lib
==================================================================
--- libtommath/win32/tommath.lib
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64-arm/libtommath.dll
Index: libtommath/win64-arm/libtommath.dll
==================================================================
--- libtommath/win64-arm/libtommath.dll
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64-arm/libtommath.dll.a
Index: libtommath/win64-arm/libtommath.dll.a
==================================================================
--- libtommath/win64-arm/libtommath.dll.a
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64-arm/tommath.lib
Index: libtommath/win64-arm/tommath.lib
==================================================================
--- libtommath/win64-arm/tommath.lib
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64/libtommath.dll
Index: libtommath/win64/libtommath.dll
==================================================================
--- libtommath/win64/libtommath.dll
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64/libtommath.dll.a
Index: libtommath/win64/libtommath.dll.a
==================================================================
--- libtommath/win64/libtommath.dll.a
+++ /dev/null
cannot compute difference between binary files
DELETED libtommath/win64/tommath.lib
Index: libtommath/win64/tommath.lib
==================================================================
--- libtommath/win64/tommath.lib
+++ /dev/null
cannot compute difference between binary files
Index: macosx/GNUmakefile
==================================================================
--- macosx/GNUmakefile
+++ macosx/GNUmakefile
@@ -1,16 +1,21 @@
-########################################################################################################
-#
-# 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).
-#
# Copyright (c) 2002-2008 Daniel A. Steffen
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-########################################################################################################
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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 ?=
Index: macosx/Tcl-Common.xcconfig
==================================================================
--- macosx/Tcl-Common.xcconfig
+++ macosx/Tcl-Common.xcconfig
@@ -1,15 +1,21 @@
-//
-// Tcl-Common.xcconfig --
-//
-// This file contains the Xcode build settings comon to all
-// project configurations in Tcl.xcodeproj.
-//
// Copyright (c) 2007-2008 Daniel A. Steffen
//
// See the file "license.terms" for information on usage and redistribution
// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+// You may distribute and/or modify this program under the terms of the GNU
+// Affero General Public License as published by the Free Software Foundation,
+// either version 3 of the License, or (at your 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
Index: macosx/Tcl-Debug.xcconfig
==================================================================
--- macosx/Tcl-Debug.xcconfig
+++ macosx/Tcl-Debug.xcconfig
@@ -1,15 +1,22 @@
+// Copyright (c) 2007 Daniel A. Steffen
+//
+// See the file "license.terms" for information on usage and redistribution
+// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+// You may distribute and/or modify this program under the terms of the GNU
+// Affero General Public License as published by the Free Software Foundation,
+// either version 3 of the License, or (at your 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.
//
-// Copyright (c) 2007 Daniel A. Steffen
-//
-// See the file "license.terms" for information on usage and redistribution
-// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#include "Tcl-Common.xcconfig"
DEBUG_INFORMATION_FORMAT = dwarf
DEAD_CODE_STRIPPING = NO
Index: macosx/Tcl-Info.plist.in
==================================================================
--- macosx/Tcl-Info.plist.in
+++ macosx/Tcl-Info.plist.in
@@ -4,10 +4,18 @@
Copyright (c) 2005-2007 Daniel A. Steffen
See the file "license.terms" for information on usage and redistribution of
this file, and for a DISCLAIMER OF ALL WARRANTIES.
-->
+
CFBundleDevelopmentRegion
English
CFBundleExecutable
Index: macosx/Tcl-Release.xcconfig
==================================================================
--- macosx/Tcl-Release.xcconfig
+++ macosx/Tcl-Release.xcconfig
@@ -1,15 +1,21 @@
-//
-// Tcl-Release.xcconfig --
-//
-// This file contains the Xcode build settings for all Release
-// project configurations in Tcl.xcodeproj.
-//
// Copyright (c) 2007 Daniel A. Steffen
//
// See the file "license.terms" for information on usage and redistribution
// of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+// You may distribute and/or modify this program under the terms of the GNU
+// Affero General Public License as published by the Free Software Foundation,
+// either version 3 of the License, or (at your 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
Index: macosx/Tclsh-Info.plist.in
==================================================================
--- macosx/Tclsh-Info.plist.in
+++ macosx/Tclsh-Info.plist.in
@@ -4,10 +4,18 @@
Copyright (c) 2005-2007 Daniel A. Steffen
See the file "license.terms" for information on usage and redistribution of
this file, and for a DISCLAIMER OF ALL WARRANTIES.
-->
+
CFBundleDevelopmentRegion
English
CFBundleExecutable
Index: macosx/tclMacOSXBundle.c
==================================================================
--- macosx/tclMacOSXBundle.c
+++ macosx/tclMacOSXBundle.c
@@ -1,18 +1,29 @@
/*
- * tclMacOSXBundle.c --
- *
- * This file implements functions that inspect CFBundle structures on
- * MacOS X.
- *
* Copyright © 2001-2009 Apple Inc.
* Copyright © 2003-2009 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
Index: macosx/tclMacOSXFCmd.c
==================================================================
--- macosx/tclMacOSXFCmd.c
+++ macosx/tclMacOSXFCmd.c
@@ -1,17 +1,28 @@
/*
- * tclMacOSXFCmd.c
- *
- * This file implements the MacOSX specific portion of file manipulation
- * subcommands of the "file" command.
- *
* Copyright © 2003-2007 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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
#include
@@ -87,11 +98,11 @@
"osType", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfOSType, /* updateStringProc */
SetOSTypeFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ 0
};
enum {
kIsInvisible = 0x4000,
};
@@ -640,11 +651,11 @@
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
Tcl_Size length;
- string = TclGetStringFromObj(objPtr, &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(
Index: macosx/tclMacOSXNotify.c
==================================================================
--- macosx/tclMacOSXNotify.c
+++ macosx/tclMacOSXNotify.c
@@ -1,20 +1,31 @@
/*
- * 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.
- *
* Copyright © 1995-1997 Sun Microsystems, Inc.
* Copyright © 2001-2009, Apple Inc.
* Copyright © 2005-2009 Daniel A. Steffen
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+/*
+ * You may distribute and/or modify this program under the terms of the GNU
+ * Affero General Public License as published by the Free Software Foundation,
+ * either version 3 of the License, or (at your 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.
Index: tests-perf/clock.perf.tcl
==================================================================
--- tests-perf/clock.perf.tcl
+++ tests-perf/clock.perf.tcl
@@ -1,21 +1,28 @@
#!/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)
#
# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
array set in {-time 500}
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
array set in $argv
}
@@ -354,20 +361,14 @@
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
# Scan : julian day (overflow)
{catch {clock scan 5373485 -format %J}}
- setup {set _(org-reptime) $_(reptime); lset _(reptime) 1 50}
-
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
- setup {set i -1}
- {clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1}
+ {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)
- setup {incr i; set j $i}
- {clock scan "[incr j -1] - 25.11.2015" -format "$j - %d.%m.%Y" -base 0 -gmt 1}
- setup {set _(reptime) $_(org-reptime); set j $i}
- {clock scan "[incr j -1] - 25.11.2015" -format "$j - %d.%m.%Y" -base 0 -gmt 1; if {!$j} {set j $i}}
+ {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 {
Index: tests-perf/comparePerf.tcl
==================================================================
--- tests-perf/comparePerf.tcl
+++ tests-perf/comparePerf.tcl
@@ -1,17 +1,25 @@
#!/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.
#
# ------------------------------------------------------------------------
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
# Usage:
# tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ...
#
# The test data from each input file is tabulated so as to compare the results
# of test runs. If a PERFFILE does not exist, it is retried by adding the
Index: tests-perf/listPerf.tcl
==================================================================
--- tests-perf/listPerf.tcl
+++ tests-perf/listPerf.tcl
@@ -1,18 +1,26 @@
#!/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.
# ------------------------------------------------------------------------
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
# Note: this file does not use the test-performance.tcl framework as we want
# more direct control over timerate options.
catch {package require twapi}
Index: tests-perf/test-performance.tcl
==================================================================
--- tests-perf/test-performance.tcl
+++ tests-perf/test-performance.tcl
@@ -1,5 +1,19 @@
+#! /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
@@ -6,16 +20,10 @@
# degradation or regression by switching between branches.
#
# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
#
# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
namespace eval ::tclTestPerf {
# warm-up interpreter compiler env, calibrate timerate measurement functionality:
# if no timerate here - import from unsupported:
Index: tests-perf/timer-event.perf.tcl
==================================================================
--- tests-perf/timer-event.perf.tcl
+++ tests-perf/timer-event.perf.tcl
@@ -1,22 +1,27 @@
#!/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).
#
# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
if {![namespace exists ::tclTestPerf]} {
source [file join [file dirname [info script]] test-performance.tcl]
}
Index: tests/aaa_exit.test
==================================================================
--- tests/aaa_exit.test
+++ tests/aaa_exit.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/abstractlist.test
==================================================================
--- tests/abstractlist.test
+++ tests/abstractlist.test
@@ -1,11 +1,19 @@
-# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c
-#
# 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::*
}
@@ -201,11 +209,11 @@
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 indicies not supported by lstring.}
+ -result {Multiple indices not supported by lstring.}
# lsort
test abstractlist-3.0 {no shimmer llength} {testobj lstring} {
set l [lstring -not SLICE $str]
@@ -491,19 +499,19 @@
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 indicies} \
+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 indicies not supported by lstring.}
+ -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]
Index: tests/all.tcl
==================================================================
--- tests/all.tcl
+++ tests/all.tcl
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
Index: tests/append.test
==================================================================
--- tests/append.test
+++ tests/append.test
@@ -1,17 +1,25 @@
-# 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.
-#
# 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::*
}
@@ -70,19 +78,19 @@
set x \uD83D$x
} -result \uD83D\uDE02
test append-3.7 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length [append x [testbytestring \x80]]
-} -result 2
+} -result 1
test append-3.8 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \xC0]
string length $x[testbytestring \x80]
-} -result 2
+} -result 1
test append-3.9 {append \xC0 \x80} -constraints testbytestring -body {
set x [testbytestring \x80]
string length [testbytestring \xC0]$x
-} -result 2
+} -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]
Index: tests/appendComp.test
==================================================================
--- tests/appendComp.test
+++ tests/appendComp.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/apply.test
==================================================================
--- tests/apply.test
+++ tests/apply.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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::*
}
Index: tests/assemble.test
==================================================================
--- tests/assemble.test
+++ tests/assemble.test
@@ -1,15 +1,22 @@
-# assemble.test --
-#
-# Test suite for the 'tcl::unsupported::assemble' command
-#
# 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
Index: tests/assemble1.bench
==================================================================
--- tests/assemble1.bench
+++ tests/assemble1.bench
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: tests/assocd.test
==================================================================
--- tests/assocd.test
+++ tests/assocd.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/async.test
==================================================================
--- tests/async.test
+++ tests/async.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/autoMkindex.test
==================================================================
--- tests/autoMkindex.test
+++ tests/autoMkindex.test
@@ -1,15 +1,23 @@
-# Commands covered: auto_mkindex auto_import
-#
-# This file contains tests related to autoloading and generating the
-# autoloading index.
-#
# 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::*
}
@@ -123,11 +131,11 @@
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
auto_mkindex . autoMkindex.tcl
file exists tclIndex
} {1}
-set element "{source -encoding utf-8 [file join . autoMkindex.tcl]}"
+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 {
@@ -188,11 +196,11 @@
} -body {
auto_mkindex_parser::command buried::myproc {name args} {
variable index
variable scriptFile
append index [list set auto_index([fullname $name])] \
- " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+ " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
@@ -214,11 +222,11 @@
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 -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n"
+ " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
auto_mkindex . autoMkindex.tcl
namespace eval tcl_autoMkindex_tmp {
set dir "."
variable auto_index
@@ -264,11 +272,11 @@
}
}
set result [lsort $dat]
close $f
set result
-} {{set auto_index(::wok::commands) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source -encoding utf-8 [file join $dir ensemblecommands.tcl]]}}
+} {{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
@@ -301,11 +309,11 @@
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 -encoding utf-8 [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source -encoding utf-8 [file join $dir pkg samename.tcl]]}}
+} -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 {
@@ -325,11 +333,11 @@
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 -encoding utf-8 [file join $dir pkg magicchar.tcl]]}
+} -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]} {} {}
Index: tests/basic.test
==================================================================
--- tests/basic.test
+++ tests/basic.test
@@ -1,5 +1,18 @@
+# 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
@@ -6,16 +19,10 @@
# 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/bigdata.test
==================================================================
--- tests/bigdata.test
+++ tests/bigdata.test
@@ -1,16 +1,24 @@
-# Test cases for large sized data
-#
# 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::*
Index: tests/binary.test
==================================================================
--- tests/binary.test
+++ tests/binary.test
@@ -1,16 +1,24 @@
-# 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.
-#
# 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::*
}
@@ -2015,14 +2023,14 @@
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
+} \x7f\x80\x00\x00
test binary-53.21 {Tcl_BinaryObjCmd: float Inf} {} {
binary format r Inf
-} \x00\x00\x80\x7F
+} \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}
Index: tests/chan.test
==================================================================
--- tests/chan.test
+++ tests/chan.test
@@ -1,13 +1,20 @@
-# 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.
-#
# 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::*
}
@@ -54,11 +61,11 @@
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} -constraints deprecated -body {
+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}
Index: tests/chanio.test
==================================================================
--- tests/chanio.test
+++ tests/chanio.test
@@ -1,19 +1,28 @@
-# -*- tcl -*-
-# 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.
-#
# 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::*
}
@@ -1090,11 +1099,11 @@
} -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 {
+} -constraints testchannel -body {
set f [open $path(test1) w]
chan configure $f -encoding binary
chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
chan close $f
set f [open $path(test1)]
@@ -5285,21 +5294,21 @@
chan close $s2
} -result {auto crlf}
test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup {
file delete $path(test1)
set l ""
-} -constraints {unix deprecated} -body {
+} -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} -constraints deprecated -setup {
+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 {}}
@@ -6720,18 +6729,19 @@
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 -translation lf -blocking 0
- chan configure $f2 -translation cr -blocking 0
+ 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 40}
+} -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]
@@ -6821,27 +6831,28 @@
chan configure $f1 -translation lf
chan puts $f1 "
chan puts ready
chan gets stdin
set f1 \[open [list $thisScript] r\]
- chan configure \$f1 -translation lf
+ 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 -translation lf
+ 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 -translation lf
+ 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 40}
+} -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
DELETED tests/clock-ivm.test
Index: tests/clock-ivm.test
==================================================================
--- tests/clock-ivm.test
+++ /dev/null
@@ -1,8 +0,0 @@
-# clock-ivm.test --
-#
-# This test file covers the 'clock' command using inverted validity mode.
-#
-# See the file "clock.test" for more information.
-
-::tcl::unsupported::clock::configure -valid [expr {![::tcl::unsupported::clock::configure -valid]}]
-source [file join [file dirname [info script]] clock.test]
Index: tests/clock.test
==================================================================
--- tests/clock.test
+++ tests/clock.test
@@ -1,29 +1,37 @@
+# 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.
+
# clock.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.
-#
-# Copyright © 2004 Kevin B. Kenny. All rights reserved.
-# Copyright © 2015 Sergey G. Brester aka sebres.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
if {[testConstraint win]} {
if {[catch {
::tcltest::loadTestedCommands
+ package require registry
}]} {
- # nothing to be done (registry loaded on demand)
+ namespace eval ::tcl::clock {variable NoRegistry {}}
}
}
package require msgcat 1.4
@@ -30,33 +38,12 @@
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:
-
-set valid_mode [::tcl::unsupported::clock::configure -valid]
-
-# Wrapper to show validity mode in the test-case name (for possible errors):
-proc test {args} {
- variable valid_mode
- lset args 0 [lindex $args 0].vm:$valid_mode
- tailcall ::tcltest::test {*}$args
-}
-
-puts [outputChannel] " Validity default mode: [expr {$valid_mode ? "on": "off"}]"
-testConstraint valid_off [expr {![::tcl::unsupported::clock::configure -valid]}]
-
-if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
- namespace import ::tcl::unsupported::timerate
-}
-
# TEST PLAN
-# clock-0:
-# several base test-cases
-#
# clock-1:
# [clock format] - tests of bad and empty arguments
#
# clock-2
# formatting of year, month and day of month
@@ -269,87 +256,35 @@
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
-# Base test cases:
-
-test clock-0.1 "initial: auto-loading of ensemble and stubs on demand" -setup {
- set i [interp create]; # because clock can be used somewhere, test it in new interp:
-} -body {
- $i eval {
- 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 ::tcl::clock::GetSystemTimeZone] ne ""}]
- clock format -now; # clock.tcl stubs expected
- lappend ret stubs:[expr {[namespace which -command ::tcl::clock::GetSystemTimeZone] ne ""}]
- }
-} -cleanup {
- interp delete $i
-} -result {ens:0 ens:1 stubs:0 stubs:1}
-test clock-0.1a "initial: safe interpreter shares clock command with parent" -setup {
- set i [interp create]
- $i eval {set sci [interp create -safe]}
-} -body {
- $i eval {
- 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 ::tcl::clock::GetSystemTimeZone] ne ""}]
- $sci eval { clock format -now }; # clock.tcl stubs expected
- lappend ret stubs:[expr {[namespace which -command ::tcl::clock::GetSystemTimeZone] ne ""}]
- }
-} -cleanup {
- interp delete $i
-} -result {ens:0 ens:1 stubs:0 stubs:1}
-
-test clock-0.2 "initial: loading of format/locale does not overwrite interp state (errorInfo)" -setup {
- # be sure - we have no cached locale/msgcat, etc:
- if {[namespace which -command ::tcl::clock::ClearCaches] ne ""} {
- ::tcl::clock::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" {
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)" {
- list [catch {clock format 0 -too-few-options-4-test} msg] $msg $::errorCode
-} [subst {1 {wrong # args: should be "clock format $syntax"} {CLOCK wrongNumArgs}}]
+} {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 opt] $msg [dict getd $opt -errorcode {}]
-} {1 {bad seconds "foo": must be -now or integer} {CLOCK badOption foo}}
+ list [catch {clock format foo} msg] $msg
+} {1 {expected integer but got "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"}}
test clock-1.3 "clock format - empty val" {
clock format 0 -gmt 1 -format ""
} {}
-test clock-1.4 "clock format - bad flag" {
- # range error message for possible extensions:
+test clock-1.4 "clock format - bad flag" {*}{
+ -body {
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
-} [subst {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}]
-test clock-1.4.1 "clock format - unexpected option for this sub-command" {
- # range error message for possible extensions:
- list [catch {clock format 0 -base 0} msg] $msg $::errorCode
-} [subst {1 {bad option "-base": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -base}}]
+ }
+ -match glob
+ -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
+}
test clock-1.5 "clock format - bad timezone" {
list [catch {clock format 0 -format "%s" -timezone :NOWHERE} msg] $msg $::errorCode
} {1 {time zone ":NOWHERE" not found} {CLOCK badTimeZone :NOWHERE}}
@@ -359,28 +294,10 @@
test clock-1.7 "clock format - option abbreviations" {
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" {
- # 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" {
- 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)}
-
# BEGIN testcases2
# Test formatting of Gregorian year, month, day, all formats
# Formats tested: %b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y %EY
@@ -15380,88 +15297,10 @@
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) } {
- 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) } {
- 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) } {
- 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) } {
- 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) } {
- 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) } {
- 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) } {
- 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) } {
- 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}] \
- -format {%EE %Y-%m-%d %T -- %J %EJ %Ej} -gmt true]
- }
- set res
-} [list \
- -172800 {B.C.E. 4713-01-03 00:00:00 -- 0000002 2.0 1.5} \
- -129600 {B.C.E. 4713-01-02 12:00:00 -- 0000001 1.5 1.0} \
- -86400 {B.C.E. 4713-01-02 00:00:00 -- 0000001 1.0 0.5} \
- -43200 {B.C.E. 4713-01-01 12:00:00 -- 0000000 0.5 0.0} \
- -1 {B.C.E. 4713-01-01 00:00:01 -- 0000000 0.00001157 -0.49998843} \
- 0 {B.C.E. 4713-01-01 00:00:00 -- 0000000 0.0 -0.5} \
- 1 {B.C.E. 4714-12-31 23:59:59 -- -000001 -0.00001157 -0.50001157} \
- 21600 {B.C.E. 4714-12-31 18:00:00 -- -000001 -0.25 -0.75} \
- 43199 {B.C.E. 4714-12-31 12:00:01 -- -000001 -0.49998843 -0.99998843} \
- 43200 {B.C.E. 4714-12-31 12:00:00 -- -000001 -0.5 -1.0} \
- 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) } {
- set res {}
- foreach i {
- -86400 -43200
- -1 0 1
- 43199 43200 43201 86400
- } {
- lappend res $i [clock format [expr {653133196800 + $i}] \
- -format {%Y-%m-%d %T -- %J %EJ %Ej} -gmt true]
- }
- set res
-} [list \
- -86400 {22666-12-19 00:00:00 -- 9999999 9999999.0 9999998.5} \
- -43200 {22666-12-19 12:00:00 -- 9999999 9999999.5 9999999.0} \
- -1 {22666-12-19 23:59:59 -- 9999999 9999999.99998843 9999999.49998843} \
- 0 {22666-12-20 00:00:00 -- 10000000 10000000.0 9999999.5} \
- 1 {22666-12-20 00:00:01 -- 10000000 10000000.00001157 9999999.50001157} \
- 43199 {22666-12-20 11:59:59 -- 10000000 10000000.49998843 9999999.99998843} \
- 43200 {22666-12-20 12:00:00 -- 10000000 10000000.5 10000000.0} \
- 43201 {22666-12-20 12:00:01 -- 10000000 10000000.50001157 10000000.00001157} \
- 86400 {22666-12-21 00:00:00 -- 10000001 10000001.0 10000000.5} \
-]
-
# END testcases4
# BEGIN testcases5
# Test formatting of Daylight Saving Time
@@ -18698,242 +18537,35 @@
test clock-6.8 {input of seconds} {
clock scan {9223372036854775807} -format %s -gmt true
} 9223372036854775807
-test clock-6.8b "clock scan - bad base" {
- 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} {
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]} {
+ 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]} -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]} -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.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
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)} {
- 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)} {
- # 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:
- set shm [string range $mon 0 $i]
- # differentiate ambiguous:
- if {[llength [lsearch -all -glob $months "${shm}*"]] <= 1} {
- # unambiguous (expected date with wull month):
- set e "12 $mon 2001"
- } else {
- # ambiguous (expected error):
- set e "input string does not match supplied format"
- }
- set s "12 $shm 2001"
- # scan and format with full month name:
- catch {clock format \
- [clock scan $s -format "%d %b %Y" -locale en_US_roman -gmt 1] \
- -format "%d %B %Y" -locale en_US_roman -gmt 1} t
- # check it corresponds the full form:
- 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)} {
- 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)} {
- 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)} {
- 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} {
- 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%" }] \
- [catch { clock scan "...%..." -format "...%%..." }]
-} {0 0}
-
-test clock-6.20 {special char tokens %n, %t} {
- clock scan "30\t06\t2009\n18\t30" -format "%d%t%m%t%Y%n%H%t%M" -gmt 1
-} 1246386600
-
-# Hi, Jeff!
-proc _testStarDates {s {days {366*2}} {step {86400}}} {
- set step [expr {int($step * 86400)}]
- # reconvert - arrange in order of stardate:
- set s [set i [clock scan [clock format $s -f "%Q" -g 1] -g 1]]
- # test:
- set wrong {}
- while {$i < $s + $days*86400} {
- set d [clock format $i -f "%Q" -g 1]
- if {![regexp {^Stardate \d+\.\d$} $d]} {
- lappend wrong "wrong: $d -- ($i) -- [clock format $i -g 1]"
- }
- if {[catch {
- set i2 [clock scan $d -f "%Q" -g 1]
- } msg]} {
- lappend wrong "$d -- ($i) -- [clock format $i -g 1]: $msg"
- }
- 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} {
- 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)} {
- _testStarDates -757382400 2 0.1
-} {}
-test clock-6.21.0.2 {Stardate 10000.1 - 10002.9 (test negative clock value -> positive Stardate)} {
- _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)} {
- _testStarDates [clock scan "Stardate 80001.1" -f %Q -g 1] 3 0.1
-} {}
-test clock-6.21.1 {Stardate} {
- 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} {
- 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)} {
- _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}
-test clock-6.22.2 {Greedy match} {
- clock format [clock scan "1111" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Thu Jan 11 00:00:00 GMT 2001}
-test clock-6.22.3 {Greedy match} {
- clock format [clock scan "11111" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Sun Nov 11 00:00:00 GMT 2001}
-test clock-6.22.4 {Greedy match} {
- clock format [clock scan "111111" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Fri Nov 11 00:00:00 GMT 2011}
-test clock-6.22.5 {Greedy match} {
- clock format [clock scan "1 1 1" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Mon Jan 01 00:00:00 GMT 2001}
-test clock-6.22.6 {Greedy match} {
- clock format [clock scan "111 1" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Thu Jan 11 00:00:00 GMT 2001}
-test clock-6.22.7 {Greedy match} {
- clock format [clock scan "1 111" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Thu Nov 01 00:00:00 GMT 2001}
-test clock-6.22.8 {Greedy match} {
- clock format [clock scan "1 11 1" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Thu Nov 01 00:00:00 GMT 2001}
-test clock-6.22.9 {Greedy match} {
- clock format [clock scan "1 11 11" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Tue Nov 01 00:00:00 GMT 2011}
-test clock-6.22.10 {Greedy match} {
- clock format [clock scan "11 11 11" -format "%d%m%y" -gmt 1] -locale en -gmt 1
-} {Fri Nov 11 00:00:00 GMT 2011}
-test clock-6.22.11 {Greedy match} {
- clock format [clock scan "1111 120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Sat Jan 01 01:02:00 GMT 2011}
-test clock-6.22.12 {Greedy match} {
- clock format [clock scan "11 1 120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Mon Jan 01 01:02:00 GMT 2001}
-test clock-6.22.13 {Greedy match} {
- clock format [clock scan "1 11 120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Mon Jan 01 01:02:00 GMT 2001}
-test clock-6.22.14 {Greedy match} {
- clock format [clock scan "111120" -format "%y%m%d%H%M%S" -gmt 1] -locale en -gmt 1
-} {Mon Jan 01 01:02:00 GMT 2001}
-test clock-6.22.15 {Greedy match} {
- clock format [clock scan "1111120" -format "%y%m%d%H%M%S" -gmt 1] -locale en -gmt 1
-} {Sat Jan 01 01:02:00 GMT 2011}
-test clock-6.22.16 {Greedy match} {
- clock format [clock scan "11121120" -format "%y%m%d%H%M%S" -gmt 1] -locale en -gmt 1
-} {Thu Dec 01 01:02:00 GMT 2011}
-test clock-6.22.17 {Greedy match} {
- clock format [clock scan "111213120" -format "%y%m%d%H%M%S" -gmt 1] -locale en -gmt 1
-} {Tue Dec 13 01:02:00 GMT 2011}
-test clock-6.22.17.1 {Greedy match (space wins as date-time separator)} {
- clock format [clock scan "1112 13120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Sun Jan 02 13:12:00 GMT 2011}
-test clock-6.22.18 {Greedy match (second space wins as date-time separator)} {
- clock format [clock scan "1112 13 120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Tue Dec 13 01:02:00 GMT 2011}
-test clock-6.22.19 {Greedy match (space wins as date-time separator)} {
- clock format [clock scan "111 213120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Mon Jan 01 21:31:20 GMT 2001}
-test clock-6.22.20 {Greedy match (second space wins as date-time separator)} {
- clock format [clock scan "111 2 13120" -format "%y%m%d %H%M%S" -gmt 1] -locale en -gmt 1
-} {Sun Jan 02 13:12:00 GMT 2011}
-
-test clock-6.23 {clock scan: text with token (bug [a858d95f4bfddafb])} {
- clock scan {text(01)} -format text(%d) -gmt 1 -base 0
-} 0
-
test clock-7.1 {Julian Day} {
clock scan 0 -format %J -gmt true
} -210866803200
@@ -18998,95 +18630,10 @@
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)} {
- 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} {
- clock scan 0 -format %Ej -gmt true
-} -210866760000
-
-test clock-7.12 {Astronomical JDN/JD} {
- 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} {
- 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} {
- 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} {
- 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} {
- 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} {
- 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} {
- 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} {
- 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} {
- clock scan {2440588 2440589} -format {%Ej %Ej} -gmt true
-} 129600
-
-test clock-7.20 {all JDN/JD are signed (and extended accept floats)} {
- 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]
- }
- set res
-} {-210866889600 -210866889600 -210866846400 -210866846400 -210866803200}
-
# BEGIN testcases8
# Test parsing of ccyymmdd
test clock-8.1 {parse ccyymmdd} {
@@ -21493,26 +21040,13 @@
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} {
- 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} {
- 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} {
- 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-9.2 {Julian day takes precedence over ccyymmdd} {
+ clock scan {2440588 20000101} -format {%J %Y%m%d} -gmt true
+} 0
# Test parsing of ccyyddd
test clock-10.1 {parse ccyyddd} {
clock scan {1970 001} -format {%Y %j} -locale en_US_roman -gmt 1
@@ -21549,91 +21083,84 @@
[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} -body {
+# 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
-} {*}$res
-test clock-11.2 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.2 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197001002 -format %m%Y%d%j -gmt 1
-} {*}$res
-test clock-11.3 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.3 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197001002 -format %d%Y%m%j -gmt 1
-} {*}$res
-test clock-11.4 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.4 {precedence of ccyyddd and ccyymmdd} {
clock scan 00219700101 -format %j%Y%m%d -gmt 1
-} {*}$res
-test clock-11.5 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.5 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700100201 -format %Y%m%j%d -gmt 1
-} {*}$res
-test clock-11.6 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.6 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197000201 -format %m%Y%j%d -gmt 1
-} {*}$res
-test clock-11.7 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.7 {precedence of ccyyddd and ccyymmdd} {
clock scan 01197000201 -format %d%Y%j%m -gmt 1
-} {*}$res
-test clock-11.8 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.8 {precedence of ccyyddd and ccyymmdd} {
clock scan 00219700101 -format %j%Y%d%m -gmt 1
-} {*}$res
-test clock-11.9 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.9 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700101002 -format %Y%d%m%j -gmt 1
-} {*}$res
-test clock-11.10 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.10 {precedence of ccyyddd and ccyymmdd} {
clock scan 01011970002 -format %m%d%Y%j -gmt 1
-} {*}$res
-test clock-11.11 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.11 {precedence of ccyyddd and ccyymmdd} {
clock scan 01011970002 -format %d%m%Y%j -gmt 1
-} {*}$res
-test clock-11.12 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.12 {precedence of ccyyddd and ccyymmdd} {
clock scan 00201197001 -format %j%m%Y%d -gmt 1
-} {*}$res
-test clock-11.13 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.13 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700100201 -format %Y%d%j%m -gmt 1
-} {*}$res
-test clock-11.14 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.14 {precedence of ccyyddd and ccyymmdd} {
clock scan 01010021970 -format %m%d%j%Y -gmt 1
-} {*}$res
-test clock-11.15 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.15 {precedence of ccyyddd and ccyymmdd} {
clock scan 01010021970 -format %d%m%j%Y -gmt 1
-} {*}$res
-test clock-11.16 {precedence of ccyymmdd over ccyyddd} -body {
+} 86400
+test clock-11.16 {precedence of ccyyddd and ccyymmdd} {
clock scan 00201011970 -format %j%m%d%Y -gmt 1
-} {*}$res
-test clock-11.17 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.17 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700020101 -format %Y%j%m%d -gmt 1
-} {*}$res
-test clock-11.18 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.18 {precedence of ccyyddd and ccyymmdd} {
clock scan 01002197001 -format %m%j%Y%d -gmt 1
-} {*}$res
-test clock-11.19 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.19 {precedence of ccyyddd and ccyymmdd} {
clock scan 01002197001 -format %d%j%Y%m -gmt 1
-} {*}$res
-test clock-11.20 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.20 {precedence of ccyyddd and ccyymmdd} {
clock scan 00201197001 -format %j%d%Y%m -gmt 1
-} {*}$res
-test clock-11.21 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.21 {precedence of ccyyddd and ccyymmdd} {
clock scan 19700020101 -format %Y%j%d%m -gmt 1
-} {*}$res
-test clock-11.22 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.22 {precedence of ccyyddd and ccyymmdd} {
clock scan 01002011970 -format %m%j%d%Y -gmt 1
-} {*}$res
-test clock-11.23 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.23 {precedence of ccyyddd and ccyymmdd} {
clock scan 01002011970 -format %d%j%m%Y -gmt 1
-} {*}$res
-test clock-11.24 {precedence of ccyymmdd over ccyyddd} -body {
+} 0
+test clock-11.24 {precedence of ccyyddd and ccyymmdd} {
clock scan 00201011970 -format %j%d%m%Y -gmt 1
-} {*}$res
-
-unset -nocomplain res
+} 0
# END testcases11
# BEGIN testcases12
# Test parsing of ccyyWwwd
@@ -21926,15 +21453,15 @@
test clock-12.96 {parse ccyyWwwd} {
clock scan {2002 W01 i} -format {%G W%V %Ow} -locale en_US_roman -gmt 1
} 1009756800
# END testcases12
-test clock-13.1 {test that %s takes precedence over ccyyWwwd} valid_off {
+test clock-13.1 {test that %s takes precedence over ccyyWwwd} {
list [clock scan {0 2000W011} -format {%s %GW%V%u} -gmt true] \
[clock scan {2000W011 0} -format {%GW%V%u %s} -gmt true]
} {0 0}
-test clock-13.2 {test that %J takes precedence over ccyyWwwd} valid_off {
+test clock-13.2 {test that %J takes precedence over ccyyWwwd} {
list [clock scan {2440588 2000W011} -format {%J %GW%V%u} -gmt true] \
[clock scan {2000W011 2440588} -format {%GW%V%u %J} -gmt true]
} {0 0}
test clock-13.3 {invalid weekday} {
catch {clock scan 2000W018 -format %GW%V%u -gmt true} result
@@ -24266,11 +23793,11 @@
test clock-15.2 {yymmdd precedence below julian day} {
list [clock scan {2440588 000101} -format {%J %y%m%d} -gmt true] \
[clock scan {000101 2440588} -format {%y%m%d %J} -gmt true]
} {0 0}
-test clock-15.3 {yymmdd precedence below yyyyWwwd} valid_off {
+test clock-15.3 {yymmdd precedence below yyyyWwwd} {
list [clock scan {1970W014000101} -format {%GW%V%u%y%m%d} -gmt true] \
[clock scan {0001011970W014} -format {%y%m%d%GW%V%u} -gmt true]
} {0 0}
# Test parsing of yyddd
@@ -24306,11 +23833,11 @@
} {0 0}
test clock-16.10 {julian day takes precedence over yyddd} {
list [clock scan {2440588 00001} -format {%J %y%j} -gmt true] \
[clock scan {00001 2440588} -format {%Y%j %J} -gmt true]
} {0 0}
-test clock-16.11 {yyddd precedence below yyyyWwwd} valid_off {
+test clock-16.11 {yyddd precedence below yyyyWwwd} {
list [clock scan {1970W01400001} -format {%GW%V%u%y%j} -gmt true] \
[clock scan {000011970W014} -format {%y%j%GW%V%u} -gmt true]
} {0 0}
# BEGIN testcases17
@@ -24607,23 +24134,23 @@
} 1009756800
# END testcases17
# Test precedence of yyWwwd
-test clock-18.1 {seconds take precedence over yyWwwd} valid_off {
+test clock-18.1 {seconds take precedence over yyWwwd} {
list [clock scan {0 00W014} -format {%s %gW%V%u} -gmt true] \
[clock scan {00W014 0} -format {%gW%V%u %s} -gmt true]
} {0 0}
test clock-18.2 {julian day takes precedence over yyddd} {
list [clock scan {2440588 00W014} -format {%J %gW%V%u} -gmt true] \
[clock scan {00W014 2440588} -format {%gW%V%u %J} -gmt true]
} {0 0}
-test clock-18.3 {yyWwwd precedence below yyyymmdd} valid_off {
+test clock-18.3 {yyWwwd precedence below yyyymmdd} {
list [clock scan {19700101 00W014} -format {%Y%m%d %gW%V%u} -gmt true] \
[clock scan {00W014 19700101} -format {%gW%V%u %Y%m%d} -gmt true]
} {0 0}
-test clock-18.4 {yyWwwd precedence below yyyyddd} valid_off {
+test clock-18.4 {yyWwwd precedence below yyyyddd} {
list [clock scan {1970001 00W014} -format {%Y%j %gW%V%u} -gmt true] \
[clock scan {00W014 1970001} -format {%gW%V%u %Y%j} -gmt true]
} {0 0}
# BEGIN testcases19
@@ -26431,52 +25958,46 @@
test clock-26.48 {parse naked day of week} {
clock scan ? -format %Ow -locale en_US_roman -gmt 1 -base 1009411200
} 1009670400
# END testcases26
-if {!$valid_mode} {
- set res {-result {0 0}}
-} else {
- set res {-returnCodes error -result "unable to convert input string: invalid day of week"}
-}
-test clock-27.1 {seconds take precedence over naked weekday} -body {
+test clock-27.1 {seconds take precedence over naked weekday} {
list [clock scan {0 1} -format {%s %u} -gmt true -base 0] \
[clock scan {1 0} -format {%u %s} -gmt true -base 0]
-} {*}$res
-test clock-27.2 {julian day takes precedence over naked weekday} -body {
+} {0 0}
+test clock-27.2 {julian day takes precedence over naked weekday} {
list [clock scan {2440588 1} -format {%J %u} -gmt true -base 0] \
[clock scan {1 2440588} -format {%u %J} -gmt true -base 0]
-} {*}$res
-test clock-27.3 {yyyymmdd over naked weekday} -body {
+} {0 0}
+test clock-27.3 {yyyymmdd over naked weekday} {
list [clock scan {19700101 1} -format {%Y%m%d %u} -gmt true -base 0] \
[clock scan {1 19700101} -format {%u %Y%m%d} -gmt true -base 0]
-} {*}$res
-test clock-27.4 {yyyyddd over naked weekday} -body {
+} {0 0}
+test clock-27.4 {yyyyddd over naked weekday} {
list [clock scan {1970001 1} -format {%Y%j %u} -gmt true -base 0] \
[clock scan {1 1970001} -format {%u %Y%j} -gmt true -base 0]
-} {*}$res
-test clock-27.5 {yymmdd over naked weekday} -body {
+} {0 0}
+test clock-27.5 {yymmdd over naked weekday} {
list [clock scan {700101 1} -format {%y%m%d %u} -gmt true -base 0] \
[clock scan {1 700101} -format {%u %y%m%d} -gmt true -base 0]
-} {*}$res
-test clock-27.6 {yyddd over naked weekday} -body {
+} {0 0}
+test clock-27.6 {yyddd over naked weekday} {
list [clock scan {70001 1} -format {%y%j %u} -gmt true -base 0] \
[clock scan {1 70001} -format {%u %y%j} -gmt true -base 0]
-} {*}$res
-test clock-27.7 {mmdd over naked weekday} -body {
+} {0 0}
+test clock-27.7 {mmdd over naked weekday} {
list [clock scan {0101 1} -format {%m%d %u} -gmt true -base 0] \
[clock scan {1 0101} -format {%u %m%d} -gmt true -base 0]
-} {*}$res
-test clock-27.8 {ddd over naked weekday} -body {
+} {0 0}
+test clock-27.8 {ddd over naked weekday} {
list [clock scan {001 1} -format {%j %u} -gmt true -base 0] \
[clock scan {1 001} -format {%u %j} -gmt true -base 0]
-} {*}$res
-test clock-27.9 {naked day of month over naked weekday} -body {
+} {0 0}
+test clock-27.9 {naked day of month over naked weekday} {
list [clock scan {01 1} -format {%d %u} -gmt true -base 0] \
[clock scan {1 01} -format {%u %d} -gmt true -base 0]
-} {*}$res
-unset -nocomplain res
+} {0 0}
test clock-28.1 {base date} {
clock scan {} -format {} -gmt true -base 1234567890
} 1234483200
@@ -35482,39 +35003,12 @@
test clock-29.1800 {time parsing} {
clock scan {2440588 xi:lix:lix pm} \
-gmt true -locale en_US_roman \
-format {%J %Ol:%OM:%OS %P}
} 86399
-
-test clock-29.1811 {parsing of several localized formats} {
- set res {}
- foreach loc {en de fr} {
- foreach fmt {"%x %X" "%X %x"} {
- lappend res [clock scan \
- [clock format 0 -format $fmt -locale $loc -gmt 1] \
- -format $fmt -locale $loc -gmt 1]
- }
- }
- set res
-} [lrepeat 6 0]
-test clock-29.1812 {parsing of several localized formats} {
- set res {}
- foreach loc {en de fr} {
- foreach fmt {"%a %d-%m-%Y" "%a %b %x-%X" "%a, %x %X" "%b, %x %X"} {
- lappend res [clock scan \
- [clock format 0 -format $fmt -locale $loc -gmt 1] \
- -format $fmt -locale $loc -gmt 1]
- }
- }
- set res
-} [lrepeat 12 0]
# END testcases29
-
-# BEGIN testcases30
-
-# Test [clock add]
test clock-30.1 {clock add years} {
set t [clock scan 2000-01-01 -format %Y-%m-%d -timezone :UTC]
set f [clock add $t 1 year -timezone :UTC]
clock format $f -format %Y-%m-%d -timezone :UTC
} {2001-01-01}
@@ -35755,99 +35249,10 @@
-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} {
- 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} {
- 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} {
- 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} {
- 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} -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} {
- set forth [clock add $start $j weekdays]
- set back [clock add $forth -$j weekdays]
- # If $s was a weekday or $j was 0, $b must be the same day.
- # Otherwise, $b must be the immediately preceeding Friday
- set fail 0
- if {$j == 0 || $startu < 6} {
- if {$start != $back} { set fail 1}
- } else {
- set friday [clock add $start -[expr {$startu % 5}] days]
- if {$friday != $back} { set fail 1 }
- }
- if {$fail} {
- set sdate [clock format $start -format {%Y-%m-%d}]
- set bdate [clock format $back -format {%Y-%m-%d}]
- return "$sdate + $j - $j := $bdate"
- }
- }
- }
- return "OK"
-} -result {OK}
-test clock-30.31 {regression test - add no int overflow} {
- list \
- [list \
- [clock add 0 1600000000 seconds 24856 days -gmt 1] \
- [clock add 0 1600000000 seconds 815 months -gmt 1] \
- [clock add 0 1600000000 seconds 69 years -gmt 1] \
- [clock add 0 1600000000 seconds 596524 hours -gmt 1] \
- [clock add 0 1600000000 seconds 35791395 minutes -gmt 1] \
- [clock add 0 1600000000 seconds 0x7fffffff seconds -gmt 1]
- ] \
- [list \
- [clock add 1600000000 24856 days -gmt 1] \
- [clock add 1600000000 815 months -gmt 1] \
- [clock add 1600000000 69 years -gmt 1] \
- [clock add 1600000000 596524 hours -gmt 1] \
- [clock add 1600000000 35791395 minutes -gmt 1] \
- [clock add 1600000000 0x7fffffff seconds -gmt 1]
- ]
-} [lrepeat 2 {3747558400 3743238400 3777452800 3747486400 3747483700 3747483647}]
-test clock-30.32 {regression test - add no int overflow} {
- list \
- [list \
- [clock add 3777452800 -1600000000 seconds -24856 days -gmt 1] \
- [clock add 3777452800 -1600000000 seconds -815 months -gmt 1] \
- [clock add 3777452800 -1600000000 seconds -69 years -gmt 1] \
- [clock add 3777452800 -1600000000 seconds -596524 hours -gmt 1] \
- [clock add 3777452800 -1600000000 seconds -35791395 minutes -gmt 1] \
- [clock add 3777452800 -1600000000 seconds -0x7fffffff seconds -gmt 1]
- ] \
- [list \
- [clock add 2177452800 -24856 days -gmt 1] \
- [clock add 2177452800 -815 months -gmt 1] \
- [clock add 2177452800 -69 years -gmt 1] \
- [clock add 2177452800 -596524 hours -gmt 1] \
- [clock add 2177452800 -35791395 minutes -gmt 1] \
- [clock add 2177452800 -0x7fffffff seconds -gmt 1]
- ]
-} [lrepeat 2 {29894400 34214400 0 29966400 29969100 29969153}]
-
-# END testcases30
-
test clock-31.1 {system locale} \
-constraints win \
-setup {
namespace eval ::tcl::clock {
@@ -36213,14 +35618,13 @@
}
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} {
list [catch {clock scan} msg] $msg
-} [subst {1 {wrong # args: should be "$syntax"}}]
+} {1 {wrong # args: should be "clock scan string ?-base seconds? ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"}}
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"*}
@@ -36250,217 +35654,48 @@
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} {
list [catch {clock scan "Jan 12" -bad arg} msg] $msg
-} [subst {1 {bad option "-bad": must be -base, -format, -gmt, -locale, -timezone or -validate}}]
+} {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.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} {
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} {
- 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]
- clock format $time -format {%b %d, %Y} -gmt true
+ set time [clock scan "Oct 23, 1992 -1 day"]
+ clock format $time -format {%b %d, %Y}
} "Oct 22, 1992"
-
test clock-34.13 {clock scan, ISO 8601 base date format} {
- set time [clock scan "19921023" -gmt true]
- clock format $time -format {%b %d, %Y} -gmt true
+ set time [clock scan "19921023"]
+ clock format $time -format {%b %d, %Y}
} "Oct 23, 1992"
test clock-34.14 {clock scan, ISO 8601 expanded date format} {
- set time [clock scan "1992-10-23" -gmt true]
- clock format $time -format {%b %d, %Y} -gmt true
+ set time [clock scan "1992-10-23"]
+ clock format $time -format {%b %d, %Y}
} "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
+ set time [clock scan "23-Oct-1992"]
+ clock format $time -format {%b %d, %Y}
} "Oct 23, 1992"
test clock-34.16 {clock scan, ISO 8601 point in time format} {
- 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)} {
- 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)} {
- 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
+ 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 {clock scan, ISO 8601 point in time format} {
- set time [clock scan "19921023 235959" -gmt true]
- clock format $time -format {%b %d, %Y %H:%M:%S} -gmt true
-} "Oct 23, 1992 23:59:59"
-test clock-34.17.2a {clock scan, ISO 8601 extended date time (YYYY-MM-DD hh:mm:ss)} {
- set time [clock scan "1992-10-23 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.2b {clock scan, ISO 8601 extended date time (YYYY-MM-DDThh:mm:ss)} {
- 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)} {
- 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} {
- 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
+ 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 {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} {
- 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"
-
-test clock-34.20.1 {clock scan tests (-TZ)} {
- set time [clock scan "31 Jan 14 23:59:59 -0100" -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Feb 01,2014 00:59:59 GMT}
-test clock-34.20.2 {clock scan tests (+TZ)} {
- set time [clock scan "31 Jan 14 23:59:59 +0100" -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jan 31,2014 22:59:59 GMT}
-test clock-34.20.3 {clock scan tests (-TZ)} {
- set time [clock scan "23:59:59 -0100" -base 0 -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jan 02,1970 00:59:59 GMT}
-test clock-34.20.4 {clock scan tests (+TZ)} {
- set time [clock scan "23:59:59 +0100" -base 0 -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jan 01,1970 22:59:59 GMT}
-test clock-34.20.5 {clock scan tests (TZ)} {
- set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST" -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jun 30,2014 21:59:59 GMT}
-test clock-34.20.6 {clock scan tests (TZ)} {
- set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET" -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jan 31,2014 22:59:59 GMT}
-test clock-34.20.7 {clock scan tests (relspec, day unit not TZ)} {
- set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Feb 08,1970 23:59:59 GMT}
-test clock-34.20.8 {clock scan tests (relspec, day unit not TZ)} {
- set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true]
- clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true
-} {Jan 09,1970 23:59:59 GMT}
-test clock-34.20.9 {clock scan tests (merid and TZ)} {
- 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)} {
- 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)} {
- 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)} {
- 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)} {
- 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)} {
- 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)} {
- 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)} {
- 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)} {
- 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]
-} {89999 89999 3599 3599}
-
+ 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
@@ -36551,31 +35786,10 @@
} "Jan 13, 2000"
test clock-34.40 {clock scan, next day of week} {
clock format [clock scan "next thursday" -base [clock scan 20000112]] \
-format {%b %d, %Y}
} "Jan 20, 2000"
-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} {
- # 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} {
- # 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"
# weekday specification and base.
test clock-34.41 {2nd monday in november} {
set res {}
foreach i {91 92 93 94 95 96} {
@@ -36723,98 +35937,10 @@
test clock-34.68 {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.69.1 {relative from base, date switch} {
- set base [clock scan "12/31/2016 23:59:59" -gmt 1]
- clock format [clock scan "+1 second" \
- -base $base -gmt 1] -gmt 1 -format {%Y-%m-%d %H:%M:%S}
-} {2017-01-01 00:00:00}
-test clock-34.69.2 {relative time, daylight switch} {
- set base [clock scan "03/27/2016" -timezone CET]
- set res {}
- lappend res [clock format [clock scan "+1 hour" \
- -base $base -timezone CET] -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]
- lappend res [clock format [clock scan "+2 hour" \
- -base $base -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.3 {relative time with day increment / daylight switch} {
- set base [clock scan "03/27/2016" -timezone CET]
- 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} {
- 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}}
-
-test clock-34.70.1 {check date in DST-hole: daylight switch CET -> CEST} {
- set res {}
- # forwards
- set base 1459033200
- for {set i 0} {$i <= 3} {incr i} {
- set d [clock scan "+$i hour" -base $base -timezone CET]
- lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]"
- }
- lappend res "#--"
- # backwards
- set base 1459044000
- for {set i 0} {$i <= 3} {incr i} {
- set d [clock scan "-$i hour" -base $base -timezone CET]
- lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]"
- }
- set res
-} [split [regsub -all {^\n|\n$} {
-1459033200 = 2016-03-27 00:00:00 CET
-1459036800 = 2016-03-27 01:00:00 CET
-1459040400 = 2016-03-27 03:00:00 CEST
-1459044000 = 2016-03-27 04:00:00 CEST
-#--
-1459044000 = 2016-03-27 04:00:00 CEST
-1459040400 = 2016-03-27 03:00:00 CEST
-1459036800 = 2016-03-27 01:00:00 CET
-1459033200 = 2016-03-27 00:00:00 CET
-} {}] \n]
-
-test clock-34.70.2 {check date in DST-hole: daylight switch CEST -> CET} {
- set res {}
- # forwards
- set base 1477782000
- for {set i 0} {$i <= 3} {incr i} {
- set d [clock scan "+$i hour" -base $base -timezone CET]
- lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]"
- }
- lappend res "#--"
- # backwards
- set base 1477792800
- for {set i 0} {$i <= 3} {incr i} {
- set d [clock scan "-$i hour" -base $base -timezone CET]
- lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]"
- }
- set res
-} [split [regsub -all {^\n|\n$} {
-1477782000 = 2016-10-30 01:00:00 CEST
-1477785600 = 2016-10-30 02:00:00 CEST
-1477789200 = 2016-10-30 02:00:00 CET
-1477792800 = 2016-10-30 03:00:00 CET
-#--
-1477792800 = 2016-10-30 03:00:00 CET
-1477789200 = 2016-10-30 02:00:00 CET
-1477785600 = 2016-10-30 02:00:00 CEST
-1477782000 = 2016-10-30 01:00:00 CEST
-} {}] \n]
-
# clock seconds
test clock-35.1 {clock seconds tests} {
expr {[clock seconds] + 1}
concat {}
} {}
@@ -36841,37 +35967,17 @@
clock format [clock scan "next may" -base [clock scan "june 1, 2000"]] \
-format %m.%Y
} "05.2001"
test clock-37.1 {%s gmt testing} {
- set s [clock scan "2017-05-10 09:00:00" -gmt 1]
+ set s [clock seconds]
set a [clock format $s -format %s -gmt 0]
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} {
- 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} {
- 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}]
-} {-7200 7200}
+ set c [expr {$b-$a}]
+} {0}
test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \
-setup {
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
@@ -36921,56 +36027,10 @@
unset oldTclTZ
}
} \
-result 1
-test clock-38.3sc {ensure cache of base is correct for :localtime if TZ-env changing / scan} \
- -setup {
- if { [info exists env(TZ)] } {
- set oldTZ $env(TZ)
- }
- } \
- -body {
- set res {}
- foreach env(TZ) {GMT-11:30 GMT-07:30 GMT-03:30 GMT} \
- i {{07:30:00} {03:30:00} {23:30:00} {20:00:00}} \
- {
- lappend res [clock scan $i -format "%H:%M:%S" -base [expr {20*60*60}] -timezone :localtime]
- }
- set res
- } \
- -cleanup {
- if { [info exists oldTZ] } {
- set env(TZ) $oldTZ
- unset oldTZ
- } else {
- unset env(TZ)
- }
- } \
- -result [lrepeat 4 [expr {20*60*60}]]
-test clock-38.3fm {ensure cache of base is correct for :localtime if TZ-env changing / format} \
- -setup {
- if { [info exists env(TZ)] } {
- set oldTZ $env(TZ)
- }
- } \
- -body {
- set res {}
- foreach env(TZ) {GMT-11:30 GMT-07:30 GMT-03:30 GMT} {
- lappend res [clock format [expr {20*60*60}] -format "%Y-%m-%dT%H:%M:%S %Z" -timezone :localtime]
- }
- set res
- } \
- -cleanup {
- if { [info exists oldTZ] } {
- set env(TZ) $oldTZ
- unset oldTZ
- } else {
- unset env(TZ)
- }
- } \
- -result {{1970-01-02T07:30:00 +1130} {1970-01-02T03:30:00 +0730} {1970-01-01T23:30:00 +0330} {1970-01-01T20:00:00 +0000}}
test clock-39.1 {regression - synonym timezones} {
clock format 0 -format {%H:%M:%S} -timezone :US/Eastern
} {19:00:00}
@@ -37039,337 +36099,33 @@
unset env(TZ)
}
} \
-result {12:34:56-0500}
-test clock-44.2 {regression test - time zone containing only two digits} \
+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
-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)} \
- -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 {
- list \
- [clock scan "11/08/2018 0612" -format "%m/%d/%Y %H%M" -gmt 1] \
- [clock scan "11/08/2018 0612" -format "%m/%d/%Y %H%M" -gmt 1] \
- [clock scan "11/08/2018 0612" -format "%m/%d/%Y %H%M" -gmt 1] \
- [clock scan " 11/08/2018 0612" -format " %m/%d/%Y %H%M" -gmt 1] \
- [clock scan " 11/08/2018 0612" -format " %m/%d/%Y %H%M" -gmt 1] \
- [clock scan " 11/08/2018 0612" -format " %m/%d/%Y %H%M" -gmt 1] \
- [clock scan "11/08/2018 0612 " -format "%m/%d/%Y %H%M " -gmt 1] \
- [clock scan "11/08/2018 0612 " -format "%m/%d/%Y %H%M " -gmt 1] \
- [clock scan "11/08/2018 0612 " -format "%m/%d/%Y %H%M " -gmt 1]
- } -result [lrepeat 9 1541657520]
-
-test clock-45.2 {compat: scan regression on spaces (multiple leading/trailing spaces in input)} \
- -body {
- set sp [string repeat " " 20]
- list \
- [clock scan "NOV 7${sp}" -format "%b %d" -base 0 -gmt 1 -locale en] \
- [clock scan "${sp}NOV 7" -format "%b %d" -base 0 -gmt 1 -locale en] \
- [clock scan "${sp}NOV 7${sp}" -format "%b %d" -base 0 -gmt 1 -locale en] \
- [clock scan "1970 NOV 7${sp}" -format "%Y %b %d" -gmt 1 -locale en] \
- [clock scan "${sp}1970 NOV 7" -format "%Y %b %d" -gmt 1 -locale en] \
- [clock scan "${sp}1970 NOV 7${sp}" -format "%Y %b %d" -gmt 1 -locale en]
- } -result [lrepeat 6 26784000]
-test clock-45.3 {compat: scan regression on spaces (shortest match)} \
- -body {
- list \
- [clock scan "11 1 120" -format "%y%m%d %H%M%S" -gmt 1] \
- [clock scan "11 1 120 " -format "%y%m%d %H%M%S" -gmt 1] \
- [clock scan " 11 1 120" -format "%y%m%d %H%M%S" -gmt 1] \
- [clock scan "11 1 120 " -format "%y%m%d %H%M%S " -gmt 1] \
- [clock scan " 11 1 120" -format " %y%m%d %H%M%S" -gmt 1]
- } -result [lrepeat 5 978310920]
-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} {
- # 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} {
- # 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] \
- [clock scan "-35791395 minutes" -base 2177452800 -gmt 1] \
- [clock scan "-2147483647 seconds" -base 2177452800 -gmt 1]
-} {29894400 34214400 0 29966400 29969100 29969153}
-
-test clock-46.1 {regression test - month zero} -constraints valid_off \
+test clock-46.1 {regression test - month zero} \
-body {
clock scan 2004-00-00 -format %Y-%m-%d
} -result [clock scan 2003-11-30 -format %Y-%m-%d]
-test clock-46.2 {regression test - month zero} -constraints valid_off \
+test clock-46.2 {regression test - month zero} \
-body {
clock scan 20040000
} -result [clock scan 2003-11-30 -format %Y-%m-%d]
-test clock-46.3 {regression test - month thirteen} -constraints valid_off \
+test clock-46.3 {regression test - month thirteen} \
-body {
clock scan 2004-13-01 -format %Y-%m-%d
} -result [clock scan 2005-01-01 -format %Y-%m-%d]
-test clock-46.4 {regression test - month thirteen} -constraints valid_off \
+test clock-46.4 {regression test - month thirteen} \
-body {
clock scan 20041301
} -result [clock scan 2005-01-01 -format %Y-%m-%d]
-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 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 {-1 -1}
-
-proc _invalid_test {args} {
- global valid_mode
- # ensure validation works TZ independently, since the conversion
- # of local time to UTC may adjust date/time tokens, depending on TZ:
- set res {}
- foreach tz {:GMT :CET {} :Europe/Berlin :localtime} {
- foreach {v} $args {
- if {$valid_mode} { # globally -valid 1
- lappend res [catch {clock scan $v -timezone $tz} msg] $msg
- } else {
- lappend res [catch {clock scan $v -valid 1 -timezone $tz} msg] $msg
- }
- }
- }
- 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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} -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
-rename _invalid_test {}
-unset -nocomplain idx relstr
-
-set dst_hole_check {
- {":Europe/Berlin"
- "2017-03-26 01:59:59" "2017-03-26 02:00:00" "2017-03-26 02:59:59" "2017-03-26 03:00:00"
- "2017-10-29 01:59:59" "2017-10-29 02:00:00"}
- {":Europe/Berlin"
- "2018-03-25 01:59:59" "2018-03-25 02:00:00" "2018-03-25 02:59:59" "2018-03-25 03:00:00"
- "2018-10-28 01:59:59" "2018-10-28 02:00:00"}
- {":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)} \
- -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 {
- unset -nocomplain res v dt tz
- } -result [lrepeat 4 \
- {*}[list 0 {*}[lrepeat 2 1 {unable to convert input string: invalid time (does not exist in this time-zone)}] 0 0 0]]
-test clock-46.19-2 {free-scan: validation rules regression: all scans successful, if -valid 0} \
- -body {
- set res {}
- 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} 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)} \
- -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 {
- unset -nocomplain res v dt tz
- } -result [lrepeat 4 \
- {*}[list 0 {*}[lrepeat 2 1 {unable to convert input string: invalid time (does not exist in this time-zone)}] 0 0 0]]
-test clock-46.19-4 {scan: validation rules regression: all scans successful, if -valid 0} \
- -body {
- set res {}
- 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"} 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}]]
-unset -nocomplain dst_hole_check
-
-proc _invalid_test {args} {
- global valid_mode
- # ensure validation works TZ independently, since the conversion
- # of local time to UTC may adjust date/time tokens, depending on TZ:
- set res {}
- foreach tz {:GMT :CET {} :Europe/Berlin :localtime} {
- foreach {v fmt} $args {
- if {$valid_mode} { # globally -valid 1
- lappend res [catch {clock scan $v -format $fmt -timezone $tz} msg] $msg
- } else {
- 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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} \
- -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} -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} -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
- unset -nocomplain orgcfg
- }
-rename _invalid_test {}
-
test clock-47.1 {regression test - four-digit time} {
clock scan 0012
} [clock scan 0012 -format %H%M]
test clock-47.2 {regression test - four digit time} {
clock scan 0039
@@ -38205,50 +36961,25 @@
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}
- -errorCode {CLOCK badOption 0x8000000000000000}
- -returnCodes error
-}
-test clock-61.1b {overflow of a wide integer on base} {*}{
- -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} {*}{
-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} {*}{
- -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)} {
- 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)} {
- 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)} -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)} -body {
- clock format -0x00F0000000000001 -gmt true
-} -returnCodes error -result {integer value too large to represent} -errorCode {CLOCK badOption -0x00F0000000000001}
+ -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}]
test clock-62.1 {Bug 1902423} {*}{
-setup {::tcl::clock::ClearCaches}
-body {
set s 1204049747
@@ -38351,23 +37082,13 @@
msgcat::mclocale $current
} -result {1}
# cleanup
+namespace delete ::testClock
::tcl::clock::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)
-}
::tcltest::cleanupTests
-namespace delete ::testClock
-unset valid_mode
-
return
# Local Variables:
# mode: tcl
# End:
Index: tests/cmdAH.test
==================================================================
--- tests/cmdAH.test
+++ tests/cmdAH.test
@@ -1,16 +1,24 @@
-# 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.
-#
# 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::*
}
@@ -318,11 +326,10 @@
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
Index: tests/cmdIL.test
==================================================================
--- tests/cmdIL.test
+++ tests/cmdIL.test
@@ -1,14 +1,22 @@
-# 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.
-#
# 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::*
}
Index: tests/cmdInfo.test
==================================================================
--- tests/cmdInfo.test
+++ tests/cmdInfo.test
@@ -1,19 +1,27 @@
+# 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.
#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/cmdMZ.test
==================================================================
--- tests/cmdMZ.test
+++ tests/cmdMZ.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/compExpr-old.test
==================================================================
--- tests/compExpr-old.test
+++ tests/compExpr-old.test
@@ -1,18 +1,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.
+
# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/compExpr.test
==================================================================
--- tests/compExpr.test
+++ tests/compExpr.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
Index: tests/compile.test
==================================================================
--- tests/compile.test
+++ tests/compile.test
@@ -1,17 +1,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 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.
#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/concat.test
==================================================================
--- tests/concat.test
+++ tests/concat.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/config.test
==================================================================
--- tests/config.test
+++ tests/config.test
@@ -1,18 +1,24 @@
-# -*- tcl -*-
-# 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.
-#
# 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::*
}
Index: tests/coroutine.test
==================================================================
--- tests/coroutine.test
+++ tests/coroutine.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/dcall.test
==================================================================
--- tests/dcall.test
+++ tests/dcall.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/dict.test
==================================================================
--- tests/dict.test
+++ tests/dict.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -149,10 +156,17 @@
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} {
Index: tests/dstring.test
==================================================================
--- tests/dstring.test
+++ tests/dstring.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/encoding.test
==================================================================
--- tests/encoding.test
+++ tests/encoding.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
@@ -37,10 +44,11 @@
# 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 {
@@ -82,11 +90,11 @@
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\"}"
+} -result "\x8c\xc1 1 {unknown encoding \"shiftjis\"}"
test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
set old [encoding system]
} -body {
encoding system shiftjis
@@ -188,11 +196,11 @@
} "512 乎"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding iso8859-1
- puts -nonewline $f "ab\x8C\xC1g"
+ puts -nonewline $f "ab\x8c\xc1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding shiftjis
set x [read $f]
close $f
@@ -224,11 +232,11 @@
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
-} "ab\x8C\xC1g"
+} "ab\x8c\xc1g"
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
@@ -238,24 +246,24 @@
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
+ 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
+ encoding convertfrom shiftjis \x8c\xc1
} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
encoding convertto iso2022 乎
-} \x1B\$B8C\x1B(B
+} \x1b\$B8C\x1b(B
test encoding-11.5.1 {LoadEncodingFile: escape file} {
encoding convertto iso2022-jp 乎
-} \x1B\$B8C\x1B(B
+} \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 {
@@ -282,14 +290,14 @@
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
+} 9\xf6\x01\x00
test encoding-11.11 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32be 😹
-} \x00\x01\xF69
+} \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 Õ]
@@ -299,12 +307,12 @@
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"
+ 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} {
@@ -313,15 +321,15 @@
append x [encoding convertfrom symbol g]
} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
encoding convertto iso2022 ab乎棙g
-} ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg
+} ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 £
-} "\xC2\xA3"
+} "\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 {
@@ -328,84 +336,84 @@
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]
+ 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"
+} -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]
+ 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]
+ 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]
+ 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é]
+ 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]
+ 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é]
+ 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 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]
+ 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]
+ 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]
+ 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]
+ 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]
+ 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"
+} "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
@@ -414,21 +422,21 @@
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]
+ 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]
+ 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]
+ 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]
@@ -439,56 +447,62 @@
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]
+ set y [encoding convertto cesu-8 \u3ff]
binary scan $y H* z
list [string length $y] $z
} {2 cfbf}
test encoding-15.25 {UtfToUtfProc CESU-8} {
encoding convertfrom cesu-8 \x00
} \x00
-test encoding-15.26 {UtfToUtfProc CESU-8} {
- encoding convertfrom -profile tcl8 cesu-8 \xC0\x80
+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
+ 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
+ encoding convertfrom -profile strict cesu-8 \xf1\x86\x83\x9c
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'}
test encoding-16.1 {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"]
+ set val [encoding convertfrom utf-16 "\xd8\xd8\xdc\xdc"]
list $val [format %x [scan $val %c]]
-} -result "\U460DC 460dc"
+} -result "\U460dc 460dc"
test encoding-16.3 {Utf16ToUtfProc} -body {
- set val [encoding convertfrom -profile tcl8 utf-16 "\xDC\xDC"]
+ set val [encoding convertfrom -profile tcl8 utf-16 "\xdc\xdc"]
list $val [format %x [scan $val %c]]
-} -result "\uDCDC dcdc"
+} -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"]
+ set val [encoding convertfrom ucs-2 "\xd8\xd8\xdc\xdc"]
list $val [format %x [scan $val %c]]
-} -result "\U460DC 460dc"
+} -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 {
@@ -496,45 +510,45 @@
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"
+} -result "\ufffd fffd"
test encoding-16.9 {Utf32ToUtfProc} -body {
- encoding convertfrom -profile tcl8 utf-32le \x00\xD8\x00\x00
-} -result \uD800
+ 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
+ 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
+ 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
+ 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
+ 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
+ encoding convertfrom -profile tcl8 utf-16le \x00\xdc
+} -result \udc00
test encoding-16.15 {Utf16ToUtfProc} -body {
- encoding convertfrom utf-16le \x00\xD8\x00\xDC
+ 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
+ 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]
+ 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} {
+ 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]
}]
@@ -548,75 +562,94 @@
} -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.20.tcl8 {Utf16ToUtfProc, bug [d19fe0a5b]} -body {
+} -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"
+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
+} -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
+ 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
+ encoding convertfrom -profile strict utf-16le \x00\xdc
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x00'}
-test encoding-16.24 {Utf32ToUtfProc} -body {
- encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF"
-} -result \uFFFD
+
+test {encoding-16.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
+} -result \ufffd
test encoding-17.1 {UtfToUtf16Proc} -body {
- encoding convertto utf-16 "\U460DC"
-} -result "\xD8\xD8\xDC\xDC"
+ 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"
+ 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"
+ 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"
+ 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"
+ encoding convertto utf-32le "\U460dc"
+} -result "\xdc\x60\x04\x00"
test encoding-17.6 {UtfToUtf32Proc} -body {
- encoding convertto utf-32be "\U460DC"
+ encoding convertto utf-32be "\U460dc"
} -result "\x00\x04\x60\xDC"
test encoding-17.7 {UtfToUtf16Proc} -body {
- encoding convertto -profile strict utf-16be "\uDCDC"
+ 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"
+ 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"
+ 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
+ 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"
+ 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"
+ 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 !)}
@@ -663,14 +696,14 @@
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.@Z> 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"
+ "\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} {
@@ -1072,34 +1126,34 @@
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xFF
+ # Note - buffers are initialized to \xff
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1} result] $result
} -result [list 0 [list nospace {} \xFF]]
test encoding-bug-183a1adcc0-2 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
- # Note - buffers are initialized to \xFF
+ # 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
+ # 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
+ # 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]]
+} -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
@@ -1120,11 +1174,11 @@
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]]
+ 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 {
@@ -1133,38 +1187,38 @@
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]]
+ 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
+ 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
+ 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
+ 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
+} -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 {
@@ -1172,11 +1226,11 @@
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
+} -result \ufffd\ufffd
# cleanup
namespace delete ::tcl::test::encoding
Index: tests/encodingVectors.tcl
==================================================================
--- tests/encodingVectors.tcl
+++ tests/encodingVectors.tcl
@@ -1,14 +1,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 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
Index: tests/env.test
==================================================================
--- tests/env.test
+++ tests/env.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/error.test
==================================================================
--- tests/error.test
+++ tests/error.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/eval.test
==================================================================
--- tests/eval.test
+++ tests/eval.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/event.test
==================================================================
--- tests/event.test
+++ tests/event.test
@@ -1,15 +1,22 @@
-# This file contains a collection of tests for the procedures in the file
-# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
-# this file into Tcl runs the tests and generates output for errors. No
-# output means no errors were found.
-#
# Copyright © 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 {
Index: tests/exec.test
==================================================================
--- tests/exec.test
+++ tests/exec.test
@@ -1,20 +1,27 @@
-# 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.
-#
# 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::*
}
@@ -710,39 +717,10 @@
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\""
-
-# Test with encoding mismatches (Bug 0f1ddc0df7fb7)
-test exec-21.1 {exec encoding mismatch on stdout} -setup {
- set path(script) [makeFile {
- fconfigure stdout -translation binary
- puts a\xe9b
- } script]
- set enc [encoding system]
- encoding system utf-8
-} -cleanup {
- removeFile $path(script)
- encoding system $enc
-} -body {
- exec [info nameofexecutable] $path(script)
-} -result a\uFFFDb
-test exec-21.2 {exec encoding mismatch on stderr} -setup {
- set path(script) [makeFile {
- fconfigure stderr -translation binary
- puts stderr a\xe9b
- } script]
- set enc [encoding system]
- encoding system utf-8
-} -cleanup {
- removeFile $path(script)
- encoding system $enc
-} -body {
- list [catch {exec [info nameofexecutable] $path(script)} r] $r
-} -result [list 1 a\uFFFDb]
-
# ----------------------------------------------------------------------
# cleanup
foreach file {gorp.file gorp.file2 echo echo2 cat wc sh sh2 sleep exit err} {
Index: tests/execute.test
==================================================================
--- tests/execute.test
+++ tests/execute.test
@@ -1,20 +1,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 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/expr-old.test
==================================================================
--- tests/expr-old.test
+++ tests/expr-old.test
@@ -1,19 +1,27 @@
+# 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.
#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/expr.test
==================================================================
--- tests/expr.test
+++ tests/expr.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/fCmd.test
==================================================================
--- tests/fCmd.test
+++ tests/fCmd.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/fileName.test
==================================================================
--- tests/fileName.test
+++ tests/fileName.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/fileSystem.test
==================================================================
--- tests/fileSystem.test
+++ tests/fileSystem.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
namespace eval ::tcl::test::fileSystem {
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
Index: tests/fileSystemEncoding.test
==================================================================
--- tests/fileSystemEncoding.test
+++ tests/fileSystemEncoding.test
@@ -1,8 +1,15 @@
#! /usr/bin/env tclsh
-# Copyright © 2019 Poor Yorick
+# 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
}
Index: tests/for-old.test
==================================================================
--- tests/for-old.test
+++ tests/for-old.test
@@ -1,18 +1,25 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/for.test
==================================================================
--- tests/for.test
+++ tests/for.test
@@ -1,15 +1,23 @@
+# 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.
-#
-# 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.
+
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/foreach.test
==================================================================
--- tests/foreach.test
+++ tests/foreach.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/format.test
==================================================================
--- tests/format.test
+++ tests/format.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/get.test
==================================================================
--- tests/get.test
+++ tests/get.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/history.test
==================================================================
--- tests/history.test
+++ tests/history.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/http.test
==================================================================
--- tests/http.test
+++ tests/http.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/http11.test
==================================================================
--- tests/http11.test
+++ tests/http11.test
@@ -1,13 +1,20 @@
-# http11.test -- -*- tcl-*-
-#
-# Test HTTP/1.1 features.
-#
# Copyright © 2009 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.
+
+# http11.test -- -*- tcl-*-
+#
+# Test HTTP/1.1 features.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/httpPipeline.test
==================================================================
--- tests/httpPipeline.test
+++ tests/httpPipeline.test
@@ -1,14 +1,21 @@
-# httpPipeline.test
-#
-# Test HTTP/1.1 concurrent requests including
-# queueing, pipelining and retries.
-#
# Copyright © 2018 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.
+
+# 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::*
}
Index: tests/httpProxy.test
==================================================================
--- tests/httpProxy.test
+++ tests/httpProxy.test
@@ -1,18 +1,25 @@
-# Commands covered: http::geturl when using a proxy server.
-#
-# This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2022-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::*
}
Index: tests/httpTest.tcl
==================================================================
--- tests/httpTest.tcl
+++ tests/httpTest.tcl
@@ -1,14 +1,22 @@
+# Copyright © 2018 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.
+
# httpTest.tcl
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
-# Copyright © 2018 Keith Nash
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------------
# "Package" httpTest for analysis of Log output of http requests.
# ------------------------------------------------------------------------------
# This is a specialised test kit for examining the presence, ordering, and
Index: tests/httpTestScript.tcl
==================================================================
--- tests/httpTestScript.tcl
+++ tests/httpTestScript.tcl
@@ -1,14 +1,22 @@
+# Copyright © 2018 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.
+
# httpTestScript.tcl
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
-# Copyright © 2018 Keith Nash
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ------------------------------------------------------------------------------
# "Package" httpTestScript for executing test scripts written in a convenient
# shorthand.
# ------------------------------------------------------------------------------
Index: tests/httpcookie.test
==================================================================
--- tests/httpcookie.test
+++ tests/httpcookie.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# Copyright © 2014 Donal K. Fellows.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/httpd
==================================================================
--- tests/httpd
+++ tests/httpd
@@ -1,14 +1,19 @@
-# -*- tcl -*-
-#
-# The httpd_ procedures implement a stub http server.
-#
# 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.
Index: tests/httpd11.tcl
==================================================================
--- tests/httpd11.tcl
+++ tests/httpd11.tcl
@@ -1,14 +1,21 @@
-# httpd11.tcl -- -*- tcl -*-
-#
-# A simple httpd for testing HTTP/1.1 client features.
-# Not suitable for use on a internet connected port.
-#
# Copyright © 2009 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.
+
+# 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]} {
Index: tests/icuUcmTests.tcl
==================================================================
--- tests/icuUcmTests.tcl
+++ tests/icuUcmTests.tcl
@@ -1,5 +1,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.
# This file is automatically generated by ucm2tests.tcl.
# Edits will be overwritten on next generation.
#
# Generates tests comparing Tcl encodings to ICU.
Index: tests/if-old.test
==================================================================
--- tests/if-old.test
+++ tests/if-old.test
@@ -1,19 +1,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: 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/if.test
==================================================================
--- tests/if.test
+++ tests/if.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/incr-old.test
==================================================================
--- tests/incr-old.test
+++ tests/incr-old.test
@@ -1,19 +1,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: 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/incr.test
==================================================================
--- tests/incr.test
+++ tests/incr.test
@@ -1,16 +1,16 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/indexObj.test
==================================================================
--- tests/indexObj.test
+++ tests/indexObj.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
Index: tests/info.test
==================================================================
--- tests/info.test
+++ tests/info.test
@@ -1,19 +1,34 @@
-# -*- tcl -*-
-# 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.
-#
# 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
@@ -31,10 +46,20 @@
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}
@@ -746,28 +771,28 @@
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 750 file */info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res}
+} -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 756 file info.test cmd {info frame 7} proc ::tcltest::RunTest}
+} -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 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0}
+} "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 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0}
+} "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 730 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest}
-* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
+} -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
@@ -790,11 +815,11 @@
} -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 793 file * cmd {info frame 0} proc ::tcltest::RunTest}
+} -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}
@@ -801,13 +826,13 @@
eval $script
} -result {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest}
test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body {
set script {etrace}
join [lrange [eval $script] 0 2] \n
-} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -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 805 file info.test cmd {eval $script} 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',
@@ -827,11 +852,11 @@
test info-24.0 {info frame, interaction, namespace eval} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 825 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 825}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
set flag 1
if {$flag} {
@@ -841,11 +866,11 @@
test info-24.1 {info frame, interaction, if} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 839 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 839}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
set flag 1
while {$flag} {
@@ -856,11 +881,11 @@
test info-24.2 {info frame, interaction, while} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 853 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 853}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
catch {
namespace eval foo {}
@@ -869,11 +894,11 @@
test info-24.3 {info frame, interaction, catch} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 867 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {}
@@ -883,11 +908,11 @@
test info-24.4 {info frame, interaction, foreach} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 880}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
for {} {1} {} {
namespace eval foo {}
@@ -897,11 +922,11 @@
test info-24.5 {info frame, interaction, for} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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
@@ -914,11 +939,11 @@
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 910 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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
@@ -929,11 +954,11 @@
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 926 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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
@@ -955,11 +980,11 @@
proc ::foo::bar {} {info frame 0}
}
test info-24.7 {info frame, interaction, dict for} {
reduce [foo::bar]
-} {type source line 955 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} "type source line [expr {$offset + 955}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo; unset k v
# -------------------------------------------------------------------------
@@ -969,11 +994,11 @@
proc ::foo::bar {} {info frame 0}
}
test info-24.8 {info frame, interaction, dict with} {
reduce [foo::bar]
-} {type source line 969 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} "type source line [expr {$offset + 969}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
unset thedict foo
# -------------------------------------------------------------------------
@@ -984,11 +1009,11 @@
set x 1
}; unset k v x
test info-24.9 {info frame, interaction, dict filter} {
reduce [foo::bar]
-} {type source line 983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} "type source line [expr {$offset + 983}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
#unset x
# -------------------------------------------------------------------------
@@ -997,18 +1022,18 @@
proc bar {} {info frame 0}
}
test info-25.0 {info frame, proc in eval} {
reduce [bar]
-} {type source line 997 file info.test cmd {info frame 0} proc ::bar level 0}
+} "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 1005 file info.test cmd {info frame 0} proc ::bar level 0}
+} "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.
@@ -1022,11 +1047,11 @@
# 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 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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
@@ -1116,11 +1141,11 @@
}
test info-33.0 {{*}, literal, direct} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 1115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {} {
@@ -1132,11 +1157,11 @@
}
test info-33.1 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 1130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 1130}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
# -------------------------------------------------------------------------
namespace {*}"
eval
@@ -1143,11 +1168,11 @@
foo
{proc bar {} {info frame 0}}
"
test info-33.2 {{*}, literal, direct} {
reduce [foo::bar]
-} {type source line 1144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} "type source line [expr {$offset + 1144}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
@@ -1169,11 +1194,11 @@
{info frame 0}
"
}
test info-33.3 {{*}, literal, simple, bytecompiled} {
reduce [foo::bar]
-} {type source line 1169 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} "type source line [expr {$offset + 1169}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
@@ -1231,14 +1256,14 @@
{info frame 0}
} 0 0
}
test info-35.0 {apply, literal} {
reduce [foo]
-} {type source line 1231 file info.test cmd {info frame 0} lambda {
+} "type source line [expr {$offset + 1231}] file info.test cmd {info frame 0} lambda {
{x y}
{info frame 0}
- } level 0}
+ } level 0"
rename foo {}
set lambda {
{x y}
{info frame 0}
@@ -1260,11 +1285,11 @@
}
set x
}
test info-36.0 {info frame, dict for, bcc} -body {
reduce [foo::bar]
-} -result {type source line 1259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 1259}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
@@ -1277,11 +1302,11 @@
set y
}
test info-36.1.0 {switch, list literal, bcc} -body {
reduce [foo::bar]
-} -result {type source line 1275 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 1275}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
@@ -1292,11 +1317,11 @@
set y
}
test info-36.1.1 {switch, multi-body literals, bcc} -body {
reduce [foo::bar]
-} -result {type source line 1291 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -result "type source line [expr {$offset + 1291}] file info.test cmd {info frame 0} proc ::foo::bar level 0"
namespace delete foo
# -------------------------------------------------------------------------
@@ -1316,13 +1341,13 @@
set res [join [lrange [etrace] 0 2] \n]
break
}]
eval $cmd
return $res
-} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -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}
+* {type eval line 1 cmd foreac proc ::tcltest::RunTest}" -cleanup {unset foo cmd res b c}
# -------------------------------------------------------------------------
# 6 cases.
## DV. direct-var - unchanged
@@ -1357,13 +1382,13 @@
set script {
set y DV.
etrace
}
join [lrange [uplevel \#0 $script] 0 2] \n
-} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -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 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
+* {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.
@@ -1376,14 +1401,14 @@
set script {
set y DPV
etrace
}
join [lrange [control y $script] 0 3] \n
-} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -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 1338 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y}
+* {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.
@@ -1393,15 +1418,15 @@
test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body {
join [lrange [datav] 0 4] \n
-} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0}
+} -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 1338 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1}
-* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}}
+* {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.
@@ -1410,14 +1435,14 @@
testConstraint testevalex [llength [info commands testevalex]]
test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body {
join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n
-} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0}
+} -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 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}}
+* {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 {
@@ -1429,13 +1454,13 @@
return $res
}
set res [::foo::bar]
namespace delete ::foo
join $res \n
-} -cleanup {unset res} -result {
-type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0
-type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {
@@ -1447,33 +1472,33 @@
}
}
abra
} -cleanup {
rename abra {}
-} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0}
+} -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 1457 file info.test cmd {info frame 0} level 0}
+} "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 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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} \
{
@@ -1480,69 +1505,69 @@
set ::res \
[reduce [info frame 0]];# line 1481
}
}
return $res
-} -cleanup {unset res} -result {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1495 file info.test cmd {info frame 0} proc ::abra level 0}
+} -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 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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} \
{
@@ -1549,11 +1574,11 @@
set ::res \
[reduce [info frame 0]];# line 1550
}
}
set res }] ; interp delete sub ; set res
-} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0}
+} -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
}
@@ -1561,11 +1586,11 @@
return "\
[reduce [info frame 0]]";# line 1562
}]
rename abra {}
set res }] ; interp delete sub ; set res
-} { type source line 1562 file info.test cmd {info frame 0} proc ::abra}
+} " 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} \
@@ -1577,11 +1602,11 @@
}
a ; set res [b]
rename a {}
rename b {}
set res
-} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0}
+} "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 } \
@@ -1590,20 +1615,20 @@
}
set res {}
lappend res [reduce [a {key }]]
lappend res [reduce [a {1alpha}]]
set res "\n[join $res \n]"
-} {
-type source line 1587 file info.test cmd {info frame 0} proc ::a level 0
-type source line 1589 file info.test cmd {info frame 0} proc ::a level 0}
+} "
+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 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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
@@ -1630,23 +1655,23 @@
}
set res {}
lappend res [a {key }]
lappend res [a {1alpha}]
set res "\n[join $res \n]"
-} {
-type source line 1624 file info.test cmd {info frame 0} proc ::a level 0
-type source line 1628 file info.test cmd {info frame 0} proc ::a level 0}
+} "
+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 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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} \
@@ -1654,13 +1679,13 @@
}
set res {}
lappend res [reduce [a 1]]
lappend res [reduce [a 0]]
set res "\n[join $res \n]"
-} {
-type source line 1652 file info.test cmd {info frame 0} proc ::a level 0
-type source line 1653 file info.test cmd {info frame 0} proc ::a level 0}
+} "
+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 "\
@@ -1670,11 +1695,11 @@
set res
}
set res [a]
rename a {}
set res
-} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0}
+} " 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 } \
@@ -1683,13 +1708,13 @@
}
set res {}
lappend res [reduce [a key]]
lappend res [reduce [a 000]]
set res "\n[join $res \n]"
-} {
-type source line 1680 file info.test cmd {info frame 0} proc ::a level 0
-type source line 1682 file info.test cmd {info frame 0} proc ::a level 0}
+} "
+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 \
@@ -1702,142 +1727,142 @@
}
set res {}
lappend res [a key]
lappend res [a 000]
set res "\n[join $res \n]"
-} {
-type source line 1696 file info.test cmd {info frame 0} proc ::a level 0
-type source line 1700 file info.test cmd {info frame 0} proc ::a level 0}
+} "
+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 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "
+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 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} " 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 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "
+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 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "
+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 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+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 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} " 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 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} " 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 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1791 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1808 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} -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 1814 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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 1820 file info.test cmd {info frame 0} proc ::tcltest::RunTest}
+} "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(1825) YES; set a(1824) 1824; set a(1826) 1826
+ 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(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832
+ 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}
+} "type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest"
# -------------------------------------------------------------------------
# literal sharing 2, bug 2933089
@@ -1873,12 +1898,12 @@
} -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 1854 file info.test cmd print_one proc ::test_info_frame level 1
-type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1}
+} -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 {
@@ -1902,15 +1927,15 @@
etrace
}
}
join [lrange [datal] 0 4] \n
}
-} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1902 file info.test cmd etrace proc ::control}
-* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1900 file info.test cmd control proc ::datal level 1}
-* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub}
+} -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 {}
@@ -1928,14 +1953,14 @@
join [lrange [control y {
set y DPL
etrace
}] 0 3] \n
}
-} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1930 file info.test cmd etrace proc ::control}
-* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control}
-* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub}
+} -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 {}
@@ -1949,13 +1974,13 @@
join [lrange [uplevel \#0 {
set y DL.
etrace
}] 0 2] \n
}
-} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0}
-* {type source line 1951 file info.test cmd etrace level 1}
-* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
+} -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}
@@ -1972,11 +1997,11 @@
}
test info-33.4 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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} {*}{
@@ -1986,11 +2011,11 @@
}
test info-33.5 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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}
@@ -2001,11 +2026,11 @@
}
test info-33.6 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {}
@@ -2016,11 +2041,11 @@
}
test info-33.7 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2031,11 +2056,11 @@
}
test info-33.8 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2046,11 +2071,11 @@
}
test info-33.9 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2061,11 +2086,11 @@
}
test info-33.10 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2076,11 +2101,11 @@
}
test info-33.11 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2089,11 +2114,11 @@
}
test info-33.12 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2104,11 +2129,11 @@
}
test info-33.13 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2118,11 +2143,11 @@
}
test info-33.14 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2132,11 +2157,11 @@
}
test info-33.15 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2145,11 +2170,11 @@
}
test info-33.16 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2157,11 +2182,11 @@
}
test info-33.17 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2169,11 +2194,11 @@
}
test info-33.18 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2182,11 +2207,11 @@
}
test info-33.19 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2194,11 +2219,11 @@
}
test info-33.20 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2207,11 +2232,11 @@
}
test info-33.21 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 -- {*}{
@@ -2220,11 +2245,11 @@
}
test info-33.22 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2234,11 +2259,11 @@
}
test info-33.23 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2248,11 +2273,11 @@
}
test info-33.24 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2262,11 +2287,11 @@
}
test info-33.25 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2276,11 +2301,11 @@
}
test info-33.26 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2289,11 +2314,11 @@
}
test info-33.27 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2302,11 +2327,11 @@
}
test info-33.28 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2315,11 +2340,11 @@
}
test info-33.29 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {} {*}{
@@ -2328,11 +2353,11 @@
}
test info-33.30 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {} {*}{
@@ -2341,11 +2366,11 @@
}
test info-33.31 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2353,11 +2378,11 @@
}
test info-33.32 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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
@@ -2366,11 +2391,11 @@
}
test info-33.33 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2378,11 +2403,11 @@
}
test info-33.34 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {*}{
@@ -2391,11 +2416,11 @@
}
test info-33.35 {{*}, literal, simple, bytecompiled} -body {
reduce [foo::bar]
} -cleanup {
namespace delete foo
-} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+} -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 {}}
Index: tests/init.test
==================================================================
--- tests/init.test
+++ tests/init.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/internals.tcl
==================================================================
--- tests/internals.tcl
+++ tests/internals.tcl
@@ -1,15 +1,22 @@
+# 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]
-#
-# 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.
if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals {
namespace path ::tcltest
Index: tests/interp.test
==================================================================
--- tests/interp.test
+++ tests/interp.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
@@ -3337,11 +3344,11 @@
}
} msg
interp delete $i
lappend result $msg
} -result {1 {time limit exceeded}}
-test interp-34.11 {time limit extension in callbacks} -constraints knownBug -setup {
+test interp-34.11 {time limit extension in callbacks} -setup {
proc cb1 {i t} {
global result
lappend result cb1
$i limit time -seconds $t -command cb2
}
Index: tests/io.test
==================================================================
--- tests/io.test
+++ tests/io.test
@@ -1,19 +1,25 @@
-# -*- tcl -*-
-# 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.
-#
# 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
}
@@ -1187,11 +1193,11 @@
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} {
+test io-7.3 {FilterInputBytes: split up character at EOF} testchannel {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82"
close $f
set f [open $path(test1)]
@@ -1612,50 +1618,76 @@
fconfigure $f -encoding utf-8 -buffersize 10
set in [read $f]
close $f
scan [string index $in end] %c
} 160
-test io-12.9 {ReadChars: multibyte chars split} -body {
- set f [open $path(test1) w]
- fconfigure $f -translation binary
- puts -nonewline $f [string repeat a 9]\xC2
- close $f
- set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
- set in [read $f]
- read $f
- scan [string index $in end] %c
-} -cleanup {
- catch {close $f}
-} -result 194
-test io-12.10 {ReadChars: multibyte chars split} -body {
- set f [open $path(test1) w]
- fconfigure $f -translation binary
- puts -nonewline $f [string repeat a 9]\xC2
- close $f
- set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -profile strict -buffersize 10
- set in [read $f]
- close $f
- scan [string index $in end] %c
-} -cleanup {
- catch {close $f}
-} -returnCodes 1 -match glob -result {error reading "file*":\
- invalid or incomplete multibyte or wide character}
-test io-12.11 {ReadChars: multibyte chars split} -body {
- set f [open $path(test1) w]
- fconfigure $f -translation binary
- puts -nonewline $f [string repeat a 9]\xC2
- close $f
- set f [open $path(test1)]
- fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
- set in [read $f]
- close $f
- scan [string index $in end] %c
-} -cleanup {
- catch {close $f}
-} -result 194
+
+
+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"
@@ -2477,28 +2509,24 @@
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
-} -body {
+} 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 {
- blocking - finalize {
+ initialize {
+ list initialize finalize watch write configure blocking
}
watch {
chan postevent $chan write
}
- 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 writable [list [info coroutine]]
@@ -2507,19 +2535,20 @@
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
- return success
-} -result success
+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
-} -body {
+} debugpurify {
variable done
variable res
after 0 [list coroutine c1 apply [list {} {
variable done
set chan [chan create r {apply {{cmd chan args} {
@@ -2545,12 +2574,14 @@
set done 1
return
}
} [namespace current]]]
vwait [namespace current]::done
- return success
-} -result success
+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} {
@@ -5851,11 +5882,11 @@
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
-test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix deprecated} -body {
+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 {}}
@@ -5863,11 +5894,11 @@
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
} -result {{} O D}
-test io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -body {
+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]
@@ -7334,12 +7365,12 @@
} {0}
test io-52.3 {TclCopyChannel} {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 cr -encoding iso8859-1 -blocking 0
+ 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]
@@ -7351,30 +7382,32 @@
} {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 -translation lf -blocking 0
- fconfigure $f2 -translation cr -blocking 0
+ 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 40}
+} {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 -translation lf -blocking 0 -buffersize 10000000
- fconfigure $f2 -translation cr -blocking 0
+ 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 40}
+} {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
@@ -7465,11 +7498,11 @@
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
- fconfigure \$f1 -translation lf
+ fconfigure \$f1 -encoding utf-8 -translation lf
puts \[read \$f1 100\]
close \$f1
"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
@@ -7476,16 +7509,17 @@
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open $path(test1) w]
- fconfigure $f2 -translation lf
+ 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 40}
+} {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
@@ -7725,10 +7759,40 @@
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Á"
@@ -9339,11 +9403,33 @@
} -cleanup {
close $f
removeFile io-75.5
} -result 4181
-test io-75.6 {incomplete utf-8 encoding, blocking gets is not ignored (-profile strict)} -setup {
+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 -encoding binary
+ # \x81 is invalid in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf \
+ -profile strict
+} -body {
+ 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 -encoding binary
# \x81 is an incomplete byte sequence in utf-8
puts -nonewline $f A\x81
@@ -9435,11 +9521,33 @@
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 {
+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 -encoding binary
+ # \x81 is invalid in utf-8
+ puts -nonewline $f A\x81
+ flush $f
+ seek $f 0
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
+ -profile strict
+} -body {
+ list [catch {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 -encoding binary
@@ -9448,42 +9556,110 @@
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
-profile strict
} -body {
- list [catch {read $f} msg data] $msg [dict get $data -data]
+ 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 utf-8 encoding eof first handling (-profile strict)} -setup {
+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 -encoding 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 -encoding binary
- # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes
- # precedence.
+ # \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.eoflater {invalid utf-8 encoding eof after handling (-profile strict)} -setup {
+
+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 -encoding 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 -encoding binary
# \x81 is invalid in utf-8. -eofchar is not detected, because it comes later.
@@ -9491,15 +9667,26 @@
flush $f
seek $f 0
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
- set res [list [catch {read $f} msg data] [eof $f] [dict get $data -data]]
+ 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 [dict get $data -data]
+ 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 \"*\":\
@@ -9516,16 +9703,24 @@
puts -nonewline $chan \x81\x1A
flush $chan
seek $chan 0
chan configure $chan -encoding utf-8 -profile strict
} -body {
- list [catch {read $chan 1} msg data] $msg [dict get $data -data]
+ 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
@@ -9539,11 +9734,46 @@
removeFile io-75.9
unset f
} -match glob -result [list {A} {error writing "*":\
invalid or incomplete multibyte or wide character}]
-test io-75.10 {
+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 -encoding 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]
@@ -9586,30 +9816,70 @@
fconfigure $f -encoding shiftjis -blocking 0 -eofchar {} -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
- lappend hd [catch {set d [read $f]} msg data] $msg [dict exists $data -data]
+ 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}
-test io-75.12 {
- invalid utf-8 encoding read is not ignored because setting the encoding to
- "binary" also set the profile to strict
+
+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 -encoding 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 -encoding binary
puts -nonewline $f A\x81
flush $f
seek $f 0
- fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf
+ fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
+ -translation lf
} -body {
catch {read $f} errmsg
lappend res $errmsg
chan configure $f -profile tcl8
seek $f 0
@@ -9622,10 +9892,33 @@
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 -encoding 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]
@@ -9638,11 +9931,11 @@
fconfigure $f -encoding utf-8 -blocking 0 -eofchar {} -translation lf \
-profile strict
} -body {
set d [read $f]
binary scan $d H* hd
- lappend hd [catch {read $f} msg data] $msg [dict exists $data -data]
+ 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*":\
@@ -9662,20 +9955,26 @@
fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \
-translation auto -profile strict
} -body {
set res [gets $chan]
lappend res [gets $chan]
- lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ 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} 0 cÀ d}
+ 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
@@ -9689,12 +9988,12 @@
} -body {
#Now try to read it with [gets]
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
lappend res [gets $chan]
- lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
- lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ 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]
@@ -9706,10 +10005,72 @@
} -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 -encoding 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 -encoding 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 -encoding 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}
# ### ### ### ######### ######### #########
@@ -9830,43 +10191,10 @@
} -returnCodes error -cleanup {
close $f
removeFile dummy
} -match glob -result {Tcl_RemoveChannelMode error:\
Bad mode, would make channel inacessible. Channel: "*"}
-
-# Encoding errors on pipeline
-# Ensures fix for exec bug [0f1ddc0df7] does not affect open
-# It should still fail unless -profile is explicitly set to replace
-test io-77.1 {open pipe encoding mismatch} -setup {
- set scriptFile [makeFile {
- fconfigure stdout -translation binary
- puts -nonewline a\xe9b
- flush stdout
- } script]
-} -cleanup {
- close $fd
- removeFile $scriptFile
-} -body {
- set fd [open |[list [info nameofexecutable] $scriptFile r+]]
- fconfigure $fd -encoding utf-8
- list [catch {read $fd} result opts] [string match {error reading "*": invalid or incomplete multibyte or wide character} $result] [dict get $opts -errorcode]
-} -result [list 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}]
-test io-77.2 {open pipe encoding mismatch - use replace profile} -setup {
- set scriptFile [makeFile {
- fconfigure stdout -translation binary
- puts -nonewline a\xe9b
- flush stdout
- } script]
-} -cleanup {
- close $fd
- removeFile $scriptFile
-} -body {
- set fd [open |[list [info nameofexecutable] $scriptFile r+]]
- fconfigure $fd -encoding utf-8 -profile replace
- read $fd
-} -result a\uFFFDb
-
# 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
Index: tests/ioCmd.test
==================================================================
--- tests/ioCmd.test
+++ tests/ioCmd.test
@@ -1,20 +1,26 @@
-# -*- tcl -*-
-# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
-# fblocked, fconfigure, open, channel, fcopy,
-# readFile, writeFile, foreachLine
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
# Copyright © 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::*
}
@@ -1405,11 +1411,11 @@
rename foo {}
set res
} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}}
test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body {
set res {}
- proc foo args {oninit cget cgetall; onfinal; track; return ""}
+ 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
Index: tests/ioTrans.test
==================================================================
--- tests/ioTrans.test
+++ tests/ioTrans.test
@@ -1,17 +1,23 @@
-# -*- tcl -*-
-# 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.
-#
# Copyright © 2007 Andreas Kupries
#
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
}
Index: tests/iogt.test
==================================================================
--- tests/iogt.test
+++ tests/iogt.test
@@ -1,16 +1,23 @@
-# -*- tcl -*-
-# Commands covered: transform, and stacking in general
+# Copyright © 2000 Ajuba Solutions.
+# Copyright © 2000 Andreas Kupries.
#
-# This file contains a collection of tests for Giot
+# 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
#
-# Copyright © 2000 Ajuba Solutions.
-# Copyright © 2000 Andreas Kupries.
-# All rights reserved.
+# This file contains a collection of tests for Giot
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/join.test
==================================================================
--- tests/join.test
+++ tests/join.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/lindex.test
==================================================================
--- tests/lindex.test
+++ tests/lindex.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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::*
}
Index: tests/link.test
==================================================================
--- tests/link.test
+++ tests/link.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/linsert.test
==================================================================
--- tests/linsert.test
+++ tests/linsert.test
@@ -1,119 +1,154 @@
-# 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.
-#
# 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::*
}
-catch {unset lis}
-catch {rename p ""}
-
-test linsert-1.1 {linsert command} {
- linsert {1 2 3 4 5} 0 a
-} {a 1 2 3 4 5}
-test linsert-1.2 {linsert command} {
- linsert {1 2 3 4 5} 1 a
-} {1 a 2 3 4 5}
-test linsert-1.3 {linsert command} {
- linsert {1 2 3 4 5} 2 a
-} {1 2 a 3 4 5}
-test linsert-1.4 {linsert command} {
- linsert {1 2 3 4 5} 3 a
-} {1 2 3 a 4 5}
-test linsert-1.5 {linsert command} {
- linsert {1 2 3 4 5} 4 a
-} {1 2 3 4 a 5}
-test linsert-1.6 {linsert command} {
- linsert {1 2 3 4 5} 5 a
-} {1 2 3 4 5 a}
-test linsert-1.7 {linsert command} {
- linsert {1 2 3 4 5} 2 one two \{three \$four
-} {1 2 one two \{three {$four} 3 4 5}
-test linsert-1.8 {linsert command} {
- linsert {\{one \$two \{three \ four \ five} 2 a b c
-} {\{one {$two} a b c \{three { four} { five}}
-test linsert-1.9 {linsert command} {
- linsert {{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 {linsert command} {
- linsert {} 2 a b c
-} {a b c}
-test linsert-1.11 {linsert command} {
- linsert {} 2 {}
-} {{}}
-test linsert-1.12 {linsert command} {
- linsert {a b "c c" d e} 3 1
-} {a b {c c} 1 d e}
-test linsert-1.13 {linsert command} {
- linsert { a b c d} 0 1 2
-} {1 2 a b c d}
-test linsert-1.14 {linsert command} {
- linsert {a b c {d e f}} 4 1 2
-} {a b c {d e f} 1 2}
-test linsert-1.15 {linsert command} {
- linsert {a b c \{\ abc} 4 q r
-} {a b c \{\ q r abc}
-test linsert-1.16 {linsert command} {
- linsert {a b c \{ abc} 4 q r
-} {a b c \{ q r abc}
-test linsert-1.17 {linsert command} {
- linsert {a b c} end q r
-} {a b c q r}
-test linsert-1.18 {linsert command} {
- linsert {a} end q r
-} {a q r}
-test linsert-1.19 {linsert command} {
- linsert {} end q r
-} {q r}
-test linsert-1.20 {linsert command, use of end-int index} {
- linsert {a b c d} end-2 e f
-} {a b e f c d}
-
-test linsert-2.1 {linsert errors} {
- list [catch linsert msg] $msg
-} {1 {wrong # args: should be "linsert list index ?element ...?"}}
-test linsert-2.2 {linsert errors} {
- list [catch {linsert a b} msg] $msg
-} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
-test linsert-2.3 {linsert errors} {
- list [catch {linsert a 12x 2} msg] $msg
-} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
-test linsert-2.4 {linsert errors} {
- list [catch {linsert \{ 12 2} msg] $msg
-} {1 {unmatched open brace in list}}
-test linsert-2.5 {syntax (TIP 323)} {
- linsert {a b c} 0
-} [list a b c]
-test linsert-2.6 {syntax (TIP 323)} {
- linsert "a\nb\nc" 0
-} [list a b c]
-
-test linsert-3.1 {linsert won't modify shared argument objects} {
- proc p {} {
- linsert "a b c" 1 "x y"
- return "a b c"
- }
- p
-} "a b c"
-test linsert-3.2 {linsert won't modify shared argument objects} {
- catch {unset lis}
- set lis [format "a \"%s\" c" "b"]
- linsert $lis 0 [string length $lis]
-} "7 a b c"
-
-# cleanup
-catch {unset lis}
-catch {rename p ""}
-::tcltest::cleanupTests
-return
+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
+}
Index: tests/list.test
==================================================================
--- tests/list.test
+++ tests/list.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/listObj.test
==================================================================
--- tests/listObj.test
+++ tests/listObj.test
@@ -1,17 +1,24 @@
+# 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.
-#
-# Copyright © 1995-1996 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -221,15 +228,26 @@
} {a f}
test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
testobj bug3598580
} 123
-test listobj-11.2 {Bug e58d7e19e9: Upwards compatibility of TclObjTypeHasProc()} testobj {
- set l [testobj buge58d7e19e9 "a x c"]
- # Since $l is a V1 objType, it's lengthProc will be accessed, but not its indexProc.
- list [llength $l] [lindex $l 2]
-} {100 c}
+
+#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} {
Index: tests/listRep.test
==================================================================
--- tests/listRep.test
+++ tests/listRep.test
@@ -1,12 +1,19 @@
-# This file contains tests that specifically exercise the internal representation
-# of a list.
-#
# Copyright © 2022 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: tests/llength.test
==================================================================
--- tests/llength.test
+++ tests/llength.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/lmap.test
==================================================================
--- tests/lmap.test
+++ tests/lmap.test
@@ -1,20 +1,27 @@
-# Commands covered: lmap, continue, break
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
# Copyright © 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::*
}
Index: tests/load.test
==================================================================
--- tests/load.test
+++ tests/load.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/lpop.test
==================================================================
--- tests/lpop.test
+++ tests/lpop.test
@@ -1,17 +1,24 @@
-# Commands covered: lpop
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
}
Index: tests/lrange.test
==================================================================
--- tests/lrange.test
+++ tests/lrange.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/lrepeat.test
==================================================================
--- tests/lrepeat.test
+++ tests/lrepeat.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# Copyright © 2003 Simon Geard.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/lreplace.test
==================================================================
--- tests/lreplace.test
+++ tests/lreplace.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/lsearch.test
==================================================================
--- tests/lsearch.test
+++ tests/lsearch.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/lseq.test
==================================================================
--- tests/lseq.test
+++ tests/lseq.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# Copyright © 2003 Simon Geard.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -328,10 +335,11 @@
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
Index: tests/lset.test
==================================================================
--- tests/lset.test
+++ tests/lset.test
@@ -1,481 +1,517 @@
-# This file is a -*- tcl -*- test script
+# 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.
-#
-# 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.
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]]
-proc failTrace {name1 name2 op} {
- error "trace failed"
-}
-
testConstraint testevalex [llength [info commands testevalex]]
-set noRead {}
-trace add variable noRead read failTrace
-set noWrite {a b c}
-trace add variable noWrite write failTrace
-
-test lset-1.1 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {lset, not compiled, data sharing} testevalex {
- set a 0
- list [testevalex {lset a $a $a}] $a
-} {0 0}
-test lset-7.10 {lset, not compiled, data sharing} testevalex {
- set a [list 0]
- list [testevalex {lset a $a $a}] $a
-} {0 0}
-
-test lset-8.1 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {lset, not compiled, entire variable} testevalex {
- set a x
- list [testevalex {lset a y}] $a
-} {y y}
-test lset-9.2 {lset, not compiled, entire variable} testevalex {
- set a x
- list [testevalex {lset a {} y}] $a
-} {y y}
-
-test lset-10.1 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {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 {lset - multiple created sublists} testevalex {
- set x {}
- testevalex {lset x 0 0 {test 1}}
-} {{{test 1}}}
-test lset-16.3 {lset - sublists 3 deep} testevalex {
- set x {}
- testevalex {lset x 0 0 0 {test 1}}
-} {{{{test 1}}}}
-test lset-16.4 {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 {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 {lset - multiple created sublists} testevalex {
- set x {}
- testevalex {lset x end+1 end+1 {test 1}}
-} {{{test 1}}}
-test lset-16.7 {lset - sublists 3 deep} testevalex {
- set x {}
- testevalex {lset x end+1 end+1 end+1 {test 1}}
-} {{{{test 1}}}}
-test lset-16.8 {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}
+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
Index: tests/lsetComp.test
==================================================================
--- tests/lsetComp.test
+++ tests/lsetComp.test
@@ -1,17 +1,22 @@
-# This file is a -*- tcl -*- test script
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/macOSXFCmd.test
==================================================================
--- tests/macOSXFCmd.test
+++ tests/macOSXFCmd.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/macOSXLoad.test
==================================================================
--- tests/macOSXLoad.test
+++ tests/macOSXLoad.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/main.test
==================================================================
--- tests/main.test
+++ tests/main.test
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
Index: tests/mathop.test
==================================================================
--- tests/mathop.test
+++ tests/mathop.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/misc.test
==================================================================
--- tests/misc.test
+++ tests/misc.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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::*
}
Index: tests/msgcat.test
==================================================================
--- tests/msgcat.test
+++ tests/msgcat.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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
Index: tests/namespace-old.test
==================================================================
--- tests/namespace-old.test
+++ tests/namespace-old.test
@@ -1,20 +1,27 @@
+# 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1997 Lucent Technologies
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/namespace.test
==================================================================
--- tests/namespace.test
+++ tests/namespace.test
@@ -1,18 +1,25 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/notify.test
==================================================================
--- tests/notify.test
+++ tests/notify.test
@@ -1,19 +1,24 @@
-# -*- tcl -*-
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/nre.test
==================================================================
--- tests/nre.test
+++ tests/nre.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/obj.test
==================================================================
--- tests/obj.test
+++ tests/obj.test
@@ -1,17 +1,24 @@
+# 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.
-#
-# Copyright © 1995-1996 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
ADDED tests/objInterface.test
Index: tests/objInterface.test
==================================================================
--- /dev/null
+++ tests/objInterface.test
@@ -0,0 +1,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
Index: tests/oo.test
==================================================================
--- tests/oo.test
+++ tests/oo.test
@@ -1,13 +1,20 @@
-# This file contains a collection of tests for Tcl's built-in object system.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
# Copyright © 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::*
Index: tests/ooNext2.test
==================================================================
--- tests/ooNext2.test
+++ tests/ooNext2.test
@@ -1,13 +1,20 @@
-# This file contains a collection of tests for Tcl's built-in object system.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
# Copyright © 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::*
Index: tests/ooProp.test
==================================================================
--- tests/ooProp.test
+++ tests/ooProp.test
@@ -1,14 +1,21 @@
-# This file contains a collection of tests for Tcl's built-in object system,
-# specifically the parts that support configurable properties on objects.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
# Copyright © 2019-2020 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
Index: tests/ooUtil.test
==================================================================
--- tests/ooUtil.test
+++ tests/ooUtil.test
@@ -1,15 +1,22 @@
-# This file contains a collection of tests for functionality originally
-# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
-# the tests and generates output for errors. No output means no errors were
-# found.
-#
# Copyright © 2014-2016 Andreas Kupries
# Copyright © 2018 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
Index: tests/opt.test
==================================================================
--- tests/opt.test
+++ tests/opt.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/package.test
==================================================================
--- tests/package.test
+++ tests/package.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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::*
}
Index: tests/parse.test
==================================================================
--- tests/parse.test
+++ tests/parse.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
Index: tests/parseExpr.test
==================================================================
--- tests/parseExpr.test
+++ tests/parseExpr.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
Index: tests/parseOld.test
==================================================================
--- tests/parseOld.test
+++ tests/parseOld.test
@@ -1,19 +1,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: 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/pid.test
==================================================================
--- tests/pid.test
+++ tests/pid.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/pkgMkIndex.test
==================================================================
--- tests/pkgMkIndex.test
+++ tests/pkgMkIndex.test
@@ -1,14 +1,21 @@
+# 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.
-#
-# Copyright © 1998-1999 Scriptics Corporation.
-# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/platform.test
==================================================================
--- tests/platform.test
+++ tests/platform.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
package require tcltest 2.5
source [file join [file dirname [info script]] tcltests.tcl]
namespace eval ::tcl::test::platform {
Index: tests/proc-old.test
==================================================================
--- tests/proc-old.test
+++ tests/proc-old.test
@@ -1,20 +1,27 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/proc.test
==================================================================
--- tests/proc.test
+++ tests/proc.test
@@ -1,19 +1,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 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/process.test
==================================================================
--- tests/process.test
+++ tests/process.test
@@ -1,14 +1,21 @@
+# 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.
-#
-# Copyright © 2017 Frederic Bonnet
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/pwd.test
==================================================================
--- tests/pwd.test
+++ tests/pwd.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/reg.test
==================================================================
--- tests/reg.test
+++ tests/reg.test
@@ -1,15 +1,22 @@
+# 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.)
-#
-# Copyright © 1998, 1999 Henry Spencer. All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/regexp.test
==================================================================
--- tests/regexp.test
+++ tests/regexp.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/regexpComp.test
==================================================================
--- tests/regexpComp.test
+++ tests/regexpComp.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/registry.test
==================================================================
--- tests/registry.test
+++ tests/registry.test
@@ -1,16 +1,23 @@
+# 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc. All rights reserved.
-# Copyright © 1998-1999 Scriptics Corporation.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/remote.tcl
==================================================================
--- tests/remote.tcl
+++ tests/remote.tcl
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
# Initialize message delimiter
# Initialize command array
catch {unset command}
Index: tests/rename.test
==================================================================
--- tests/rename.test
+++ tests/rename.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/resolver.test
==================================================================
--- tests/resolver.test
+++ tests/resolver.test
@@ -1,16 +1,23 @@
-# 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.
-#
# Copyright © 2011 Gustaf Neumann
# Copyright © 2011 Stefan Sobernig
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
}
Index: tests/result.test
==================================================================
--- tests/result.test
+++ tests/result.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/safe-stock.test
==================================================================
--- tests/safe-stock.test
+++ tests/safe-stock.test
@@ -1,5 +1,18 @@
+# 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
@@ -19,16 +32,10 @@
# - Tests 7.[124], 9.1[13] use "package require opt".
# - Tests 9.1[13] also use "package require tcl::idna".
# - The corresponding tests in safe.test use example packages provided in
# subdirectory auto0 of the tests directory, which are independent of any
# changes made to the packages provided with Tcl.
-#
-# Copyright © 1995-1996 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/safe-zipfs.test
==================================================================
--- tests/safe-zipfs.test
+++ tests/safe-zipfs.test
@@ -1,19 +1,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.
+
# safe-zipfs.test --
#
# This file contains tests for safe Tcl that test its compatibility with the
# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison
# with similar tests in safe.test that do not use the zipfs file system.
#
# Sourcing this file into tcl runs the tests and generates output for errors.
# No output means no errors were found.
-#
-# Copyright © 1995-1996 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
apply [list {} {
global auto_path
global tcl_library
Index: tests/safe.test
==================================================================
--- tests/safe.test
+++ tests/safe.test
@@ -1,5 +1,18 @@
+# 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.
@@ -11,16 +24,10 @@
# - 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.
-#
-# Copyright © 1995-1996 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/scan.test
==================================================================
--- tests/scan.test
+++ tests/scan.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/security.test
==================================================================
--- tests/security.test
+++ tests/security.test
@@ -1,16 +1,23 @@
+# 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/set-old.test
==================================================================
--- tests/set-old.test
+++ tests/set-old.test
@@ -1,19 +1,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: 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/set.test
==================================================================
--- tests/set.test
+++ tests/set.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/socket.test
==================================================================
--- tests/socket.test
+++ tests/socket.test
@@ -1,16 +1,24 @@
+# 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.
#
-# 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.
# Running socket tests with a remote server:
# ------------------------------------------
#
# Some tests in socket.test depend on the existence of a remote server to
@@ -2396,13 +2404,15 @@
} -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 {set x 1}
+ fileevent $sock writable {incr x}
vwait x
close $sock
} -cleanup {
catch {close $sock}
unset x
Index: tests/source.test
==================================================================
--- tests/source.test
+++ tests/source.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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
}
Index: tests/split.test
==================================================================
--- tests/split.test
+++ tests/split.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/stack.test
==================================================================
--- tests/stack.test
+++ tests/stack.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# Copyright © 1998-2000 Ajuba Solutions.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/string.test
==================================================================
--- tests/string.test
+++ tests/string.test
@@ -1,18 +1,25 @@
-# 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.
-#
# 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::*
}
Index: tests/stringObj.test
==================================================================
--- tests/stringObj.test
+++ tests/stringObj.test
@@ -1,18 +1,25 @@
+# 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.
-#
-# Copyright © 1995-1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/subst.test
==================================================================
--- tests/subst.test
+++ tests/subst.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/switch.test
==================================================================
--- tests/switch.test
+++ tests/switch.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/tailcall.test
==================================================================
--- tests/tailcall.test
+++ tests/tailcall.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/tcltest.test
==================================================================
--- tests/tcltest.test
+++ tests/tcltest.test
@@ -1,12 +1,19 @@
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
# Copyright © 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
@@ -13,11 +20,10 @@
# 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::*
}
Index: tests/tcltests.tcl
==================================================================
--- tests/tcltests.tcl
+++ tests/tcltests.tcl
@@ -1,14 +1,20 @@
#! /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 deprecated [expr {![tcl::build-info no-deprecate]}]
testConstraint debug [tcl::build-info debug]
testConstraint purify [tcl::build-info purify]
testConstraint debugpurify [
expr {
![tcl::build-info memdebug]
Index: tests/thread.test
==================================================================
--- tests/thread.test
+++ tests/thread.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/timer.test
==================================================================
--- tests/timer.test
+++ tests/timer.test
@@ -1,19 +1,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 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/tm.test
==================================================================
--- tests/tm.test
+++ tests/tm.test
@@ -1,12 +1,19 @@
+# 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.
-#
-# Copyright © 2004 Donal K. Fellows.
-# All rights reserved.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/trace.test
==================================================================
--- tests/trace.test
+++ tests/trace.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/unixFCmd.test
==================================================================
--- tests/unixFCmd.test
+++ tests/unixFCmd.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/unixFile.test
==================================================================
--- tests/unixFile.test
+++ tests/unixFile.test
@@ -1,15 +1,22 @@
+# Copyright © 1998-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.
-#
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/unixForkEvent.test
==================================================================
--- tests/unixForkEvent.test
+++ tests/unixForkEvent.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
Index: tests/unixInit.test
==================================================================
--- tests/unixInit.test
+++ tests/unixInit.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/unixNotfy.test
==================================================================
--- tests/unixNotfy.test
+++ tests/unixNotfy.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/unknown.test
==================================================================
--- tests/unknown.test
+++ tests/unknown.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/unload.test
==================================================================
--- tests/unload.test
+++ tests/unload.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/uplevel.test
==================================================================
--- tests/uplevel.test
+++ tests/uplevel.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/upvar.test
==================================================================
--- tests/upvar.test
+++ tests/upvar.test
@@ -1,17 +1,24 @@
-# 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.
-#
# 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::*
}
Index: tests/utf.test
==================================================================
--- tests/utf.test
+++ tests/utf.test
@@ -1,14 +1,21 @@
-# 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.
-#
# 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::*
}
@@ -77,15 +84,15 @@
return $hi\uDE02
} \uD83D\uDE02
test utf-1.16 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
set lo [testbytestring \x80]
string length [testbytestring \xC0]$lo
-} 2
+} 1
test utf-1.17 {Tcl_UniCharToUtf: \xC0 + \x80} testbytestring {
set hi [testbytestring \xC0]
string length $hi[testbytestring \x80]
-} 2
+} 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} {
Index: tests/utfext.test
==================================================================
--- tests/utfext.test
+++ tests/utfext.test
@@ -1,13 +1,21 @@
-# This file contains a collection of tests for Tcl_UtfToExternal and
-# Tcl_UtfToExternal. Sourcing this file into Tcl runs the tests and generates
-# errors. No output means no errors found.
-#
# Copyright (c) 2023 Ashok P. Nadkarni
+# Copyright (c) 2024 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.
+
+# This file contains a collection of tests for Tcl_UtfToExternal and
+# Tcl_UtfToExternal. Sourcing this file into Tcl runs the tests and generates
+# errors. No output means no errors found.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
@@ -72,11 +80,18 @@
# Another bug - char limit not obeyed
# % set cv 2
# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
-test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body {
+test TableToUtf-bug-5be203d6ca-profilestrict {Bug 5be203d6ca - truncated prefix in table encoding} -body {
+ set src \x82\x4F\x82\x50\x82
+ lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start profilestrict} 0 16 srcRead dstWritten charsWritten] buf
+ set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start profilestrict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+ lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end profiletcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
+} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1]
+
+test TableToUtf-bug-5be203d6ca-profiletcl8 {Bug 5be203d6ca - truncated prefix in table encoding} -body {
set src \x82\x4F\x82\x50\x82
lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] buf
set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end profiletcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding
Index: tests/util.test
==================================================================
--- tests/util.test
+++ tests/util.test
@@ -1,13 +1,20 @@
-# This file is a Tcl script to test the code in the file tclUtil.c.
-# This file is organized in the standard fashion for Tcl tests.
-#
# Copyright © 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::*
}
Index: tests/var.test
==================================================================
--- tests/var.test
+++ tests/var.test
@@ -1,20 +1,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 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.
-#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/while-old.test
==================================================================
--- tests/while-old.test
+++ tests/while-old.test
@@ -1,19 +1,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: 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/while.test
==================================================================
--- tests/while.test
+++ tests/while.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/winConsole.test
==================================================================
--- tests/winConsole.test
+++ tests/winConsole.test
@@ -1,16 +1,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.
+
# 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.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/winDde.test
==================================================================
--- tests/winDde.test
+++ tests/winDde.test
@@ -1,15 +1,22 @@
+# 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.
-#
-# Copyright © 1999 Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/winFCmd.test
==================================================================
--- tests/winFCmd.test
+++ tests/winFCmd.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/winFile.test
==================================================================
--- tests/winFile.test
+++ tests/winFile.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/winNotify.test
==================================================================
--- tests/winNotify.test
+++ tests/winNotify.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/winPipe.test
==================================================================
--- tests/winPipe.test
+++ tests/winPipe.test
@@ -1,18 +1,24 @@
+# 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.
-#
-# 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.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
Index: tests/winTime.test
==================================================================
--- tests/winTime.test
+++ tests/winTime.test
@@ -1,16 +1,23 @@
-# 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.
-#
# 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::*
}
Index: tests/zipfs.test
==================================================================
--- tests/zipfs.test
+++ tests/zipfs.test
@@ -1,18 +1,24 @@
-# The file tests the tclZlib.c file.
-#
-# This file contains a collection of tests for one or more of the Tcl built-in
-# commands. Sourcing this file into Tcl runs the tests and generates output
-# for errors. No output means no errors were found.
-#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2023 Ashok P. Nadkarni
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
}
Index: tests/zlib.test
==================================================================
--- tests/zlib.test
+++ tests/zlib.test
@@ -1,16 +1,23 @@
-# The file tests the tclZlib.c file.
-#
-# This file contains a collection of tests for one or more of the Tcl built-in
-# commands. Sourcing this file into Tcl runs the tests and generates output
-# for errors. No output means no errors were found.
-#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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::*
}
Index: tools/checkLibraryDoc.tcl
==================================================================
--- tools/checkLibraryDoc.tcl
+++ tools/checkLibraryDoc.tcl
@@ -1,5 +1,15 @@
+# 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
@@ -13,13 +23,11 @@
# 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.
-#
-# Copyright © 1998-1999 Scriptics Corporation.
-# All rights reserved.
+
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}]} {
Index: tools/encoding/Makefile
==================================================================
--- tools/encoding/Makefile
+++ tools/encoding/Makefile
@@ -1,15 +1,5 @@
-#
-# 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:
-#
#---------------------------------------------------------------------------
#
# Copyright (c) 1996 Unicode, Inc. All Rights reserved.
#
# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
@@ -28,12 +18,34 @@
#
# 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.
#
@@ -42,18 +54,11 @@
# 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.
-#
-# 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
-#
+
EUC_ENCODINGS = euc-cn.txt euc-kr.txt euc-jp.txt
encodings: clean txt2enc $(EUC_ENCODINGS)
@echo Compiling encoding files.
Index: tools/encoding/txt2enc.c
==================================================================
--- tools/encoding/txt2enc.c
+++ tools/encoding/txt2enc.c
@@ -1,20 +1,31 @@
/*
- * 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.
- *
* 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
#include
#include
#include
#include
Index: tools/findBadExternals.tcl
==================================================================
--- tools/findBadExternals.tcl
+++ tools/findBadExternals.tcl
@@ -1,5 +1,17 @@
+# 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
@@ -7,16 +19,10 @@
# other code.
#
# Usage:
#
# tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll
-#
-# 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.
-#----------------------------------------------------------------------
proc main {argc argv} {
if {$argc != 1} {
puts stderr "syntax is: [info script] libtcl"
Index: tools/genStubs.tcl
==================================================================
--- tools/genStubs.tcl
+++ tools/genStubs.tcl
@@ -1,16 +1,22 @@
-# genStubs.tcl --
-#
-# This script generates a set of stub files for a given
-# interface.
-#
-#
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2007 Daniel A. Steffen
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: tools/index.tcl
==================================================================
--- tools/index.tcl
+++ tools/index.tcl
@@ -1,15 +1,22 @@
+# 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.
-#
-# 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.
# Global variables used by these scripts:
#
# state - state variable that controls action of text proc.
#
Index: tools/installData.tcl
==================================================================
--- tools/installData.tcl
+++ tools/installData.tcl
@@ -1,22 +1,27 @@
-#!/bin/sh
-#\
-exec tclsh "$0" ${1+"$@"}
+#! /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.
#
-#----------------------------------------------------------------------
-#
-# 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.
#----------------------------------------------------------------------
proc copyDir {d1 d2} {
puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
Index: tools/installVfs.tcl
==================================================================
--- tools/installVfs.tcl
+++ tools/installVfs.tcl
@@ -1,20 +1,24 @@
-#!/bin/sh
-#\
-exec tclsh "$0" ${1+"$@"}
+#! /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
#
-#----------------------------------------------------------------------
-#
-# Copyright © 2018 Sean Woods. All rights reserved.
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
proc mapDir {resultvar prefix filepath} {
upvar 1 $resultvar result
if {![info exists result]} {
Index: tools/loadICU.tcl
==================================================================
--- tools/loadICU.tcl
+++ tools/loadICU.tcl
@@ -1,6 +1,19 @@
-#----------------------------------------------------------------------
+#! /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/)
@@ -18,15 +31,10 @@
# None.
#
# Side effects:
# Creates the message catalogs.
#
-#----------------------------------------------------------------------
-#
-# Copyright © 2004 Kevin B. Kenny. All rights reserved.
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#----------------------------------------------------------------------
puts stdout "TODO: output in UTF-8 in stead of using \\uhhhh sequences"
exit; # Remove those two lines after modifying this tool.
Index: tools/makeHeader.tcl
==================================================================
--- tools/makeHeader.tcl
+++ tools/makeHeader.tcl
@@ -1,14 +1,22 @@
+# 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.
#
-# Copyright © 2018 Donal K. Fellows
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require Tcl 8.6-
namespace eval makeHeader {
Index: tools/makeTestCases.tcl
==================================================================
--- tools/makeTestCases.tcl
+++ tools/makeTestCases.tcl
@@ -1,5 +1,13 @@
+#! /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]]]
Index: tools/mkVfs.tcl
==================================================================
--- tools/mkVfs.tcl
+++ tools/mkVfs.tcl
@@ -1,5 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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
Index: tools/mkdepend.tcl
==================================================================
--- tools/mkdepend.tcl
+++ tools/mkdepend.tcl
@@ -1,9 +1,6 @@
#==============================================================================
-#
-# mkdepend : generate dependency information from C/C++ files
-#
# 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
@@ -18,16 +15,26 @@
# 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 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]
Index: tools/regexpTestLib.tcl
==================================================================
--- tools/regexpTestLib.tcl
+++ tools/regexpTestLib.tcl
@@ -1,12 +1,19 @@
+# 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.
-#
-# Copyright © 1996 Sun Microsystems, Inc.
proc readInputFile {} {
global inFileName
global lineArray
Index: tools/tclOOScript.tcl
==================================================================
--- tools/tclOOScript.tcl
+++ tools/tclOOScript.tcl
@@ -1,17 +1,24 @@
-# tclOOScript.h --
-#
-# This file contains support scripts for TclOO. They are defined here so
-# that the code can be definitely run even in safe interpreters; TclOO's
-# core setup is safe.
-#
# Copyright © 2012-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 {}
#
Index: tools/tclZIC.tcl
==================================================================
--- tools/tclZIC.tcl
+++ tools/tclZIC.tcl
@@ -1,5 +1,16 @@
+# 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
@@ -21,15 +32,10 @@
#
# 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.
#
-#----------------------------------------------------------------------
-#
-# 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.
#----------------------------------------------------------------------
# Define the names of the Olson files that we need to load.
# We avoid the solar time files and the leap seconds.
Index: tools/tcltk-man2html-utils.tcl
==================================================================
--- tools/tcltk-man2html-utils.tcl
+++ tools/tcltk-man2html-utils.tcl
@@ -1,12 +1,18 @@
-##
-## 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.
-##
-## Copyright © 1995-1997 Roger E. Critchlow Jr
-## Copyright © 2004-2011 Donal K. Fellows
+# 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
Index: tools/tcltk-man2html.tcl
==================================================================
--- tools/tcltk-man2html.tcl
+++ tools/tcltk-man2html.tcl
@@ -1,7 +1,17 @@
#!/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)."
@@ -16,13 +26,10 @@
# engineering. In that sense it's probably a good example of things
# that a scripting language, like Tcl, can do well. It is offered as
# an example of how someone might convert a specific set of man pages
# into hypertext, not as a general solution to the problem. If you
# try to use this, you'll be very much on your own.
-#
-# Copyright © 1995-1997 Roger E. Critchlow Jr
-# Copyright © 2004-2010 Donal K. Fellows
set ::Version "50/9.0"
set ::CSSFILE "docs.css"
##
Index: tools/tsdPerf.c
==================================================================
--- tools/tsdPerf.c
+++ tools/tsdPerf.c
@@ -1,5 +1,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.
+ */
+
#include
extern DLLEXPORT Tcl_LibraryInitProc Tsdperf_Init;
static Tcl_ThreadDataKey key;
Index: tools/tsdPerf.tcl
==================================================================
--- tools/tsdPerf.tcl
+++ tools/tsdPerf.tcl
@@ -1,5 +1,13 @@
+#! /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} {
Index: tools/uniClass.tcl
==================================================================
--- tools/uniClass.tcl
+++ tools/uniClass.tcl
@@ -1,18 +1,21 @@
-#!/bin/sh
-# The next line is executed by /bin/sh, but not tcl \
-exec tclsh "$0" ${1+"$@"}
+#! /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)} {
Index: tools/uniParse.tcl
==================================================================
--- tools/uniParse.tcl
+++ tools/uniParse.tcl
@@ -1,15 +1,24 @@
+#! /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
-#
-# Copyright © 1998-1999 Scriptics Corporation.
-# All rights reserved.
namespace eval uni {
set shift 5; # number of bits of data within a page
# This value can be adjusted to find the
@@ -210,11 +219,10 @@
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"
- puts $f "#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6"
set line " ,"
}
append line [lindex $pMap $i]
if {$i != $last} {
append line ", "
@@ -223,11 +231,10 @@
puts $f [string trimright $line]
set line " "
}
}
puts $f $line
- puts $f "#endif /* TCL_UTF_MAX > 3 */"
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
@@ -240,11 +247,10 @@
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,"]
- puts $f "#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6"
set line " ,"
}
for {set j 0} {$j <= $lastj} {incr j} {
append line [lindex $page $j]
if {$j != $lastj || $i != $lasti} {
@@ -255,11 +261,10 @@
set line " "
}
}
}
puts $f $line
- puts $f "#endif /* TCL_UTF_MAX > 3 */"
puts $f "};
/*
* Each group represents a unique set of character attributes. The attributes
* are encoded into a 32-bit value as follows:
@@ -340,15 +345,11 @@
}
}
puts $f $line
puts -nonewline $f "};
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
-# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= [format 0x%X $next])
-#else
-# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
-#endif
+#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.
*/
@@ -399,18 +400,14 @@
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
-#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
-# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
-#else
-# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
-#endif
+#define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
"
close $f
}
uni::main
return
Index: tools/valgrind_check_success
==================================================================
--- tools/valgrind_check_success
+++ tools/valgrind_check_success
@@ -1,7 +1,15 @@
#! /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]
Index: unix/Makefile.in
==================================================================
--- unix/Makefile.in
+++ unix/Makefile.in
@@ -1,6 +1,12 @@
+# You may distribute and/or modify this program under the terms of the GNU
+# Affero General Public License as published by the Free Software Foundation,
+# either version 3 of the License, or (at your 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.
@@ -134,15 +140,10 @@
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
-# To compile without backward compatibility and deprecated code uncomment the
-# following
-NO_DEPRECATED_FLAGS =
-#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED
-
# 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
@@ -291,31 +292,33 @@
${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 tclTestABSList.o
+ tclThreadTest.o tclUnixTest.o tclTestObjInterface.o \
+ tclTestObjInterfaceInteger.o tclTestABSList.o
-XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
- tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.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 tclClockFmt.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
+ tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \
tclEncoding.o tclEnsemble.o \
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
tclHash.o tclHistory.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 tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
- tclPkg.o tclPkgConfig.o tclPosixStr.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 tclStringObj.o tclStrIdxTree.o \
+ tclResolve.o tclResult.o tclScan.o tclStringObj.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
tclTomMathInterface.o tclZipfs.o
@@ -409,11 +412,10 @@
$(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 \
@@ -449,10 +451,11 @@
$(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 \
@@ -465,15 +468,16 @@
$(GENERIC_DIR)/tclResolve.c \
$(GENERIC_DIR)/tclResult.c \
$(GENERIC_DIR)/tclScan.c \
$(GENERIC_DIR)/tclStubInit.c \
$(GENERIC_DIR)/tclStringObj.c \
- $(GENERIC_DIR)/tclStrIdxTree.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 \
@@ -1263,11 +1267,10 @@
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
@@ -1303,26 +1306,23 @@
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c
tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c
-tclClock.o: $(GENERIC_DIR)/tclClock.c $(TCLDATEHDR)
+tclClock.o: $(GENERIC_DIR)/tclClock.c
$(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)
+tclDate.o: $(GENERIC_DIR)/tclDate.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c
tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c
@@ -1413,10 +1413,13 @@
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
@@ -1539,13 +1542,10 @@
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclScan.c
tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c
-tclStrIdxTree.o: $(GENERIC_DIR)/tclStrIdxTree.c $(GENERIC_DIR)/tclStrIdxTree.h $(MATHHDRS)
- $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrIdxTree.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
@@ -1579,10 +1579,17 @@
$(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
DELETED unix/configure
Index: unix/configure
==================================================================
--- unix/configure
+++ /dev/null
@@ -1,12665 +0,0 @@
-#! /bin/sh
-# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.72 for tcl 9.0.
-#
-#
-# Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation,
-# Inc.
-#
-#
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-## -------------------- ##
-## M4sh Initialization. ##
-## -------------------- ##
-
-# Be more Bourne compatible
-DUALCASE=1; export DUALCASE # for MKS sh
-if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
-then :
- emulate sh
- NULLCMD=:
- # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which
- # is contrary to our usage. Disable this feature.
- alias -g '${1+"$@"}'='"$@"'
- setopt NO_GLOB_SUBST
-else case e in #(
- e) case `(set -o) 2>/dev/null` in #(
- *posix*) :
- set -o posix ;; #(
- *) :
- ;;
-esac ;;
-esac
-fi
-
-
-
-# Reset variables that may have inherited troublesome values from
-# the environment.
-
-# IFS needs to be set, to space, tab, and newline, in precisely that order.
-# (If _AS_PATH_WALK were called with IFS unset, it would have the
-# side effect of setting IFS to empty, thus disabling word splitting.)
-# Quoting is to prevent editors from complaining about space-tab.
-as_nl='
-'
-export as_nl
-IFS=" "" $as_nl"
-
-PS1='$ '
-PS2='> '
-PS4='+ '
-
-# Ensure predictable behavior from utilities with locale-dependent output.
-LC_ALL=C
-export LC_ALL
-LANGUAGE=C
-export LANGUAGE
-
-# We cannot yet rely on "unset" to work, but we need these variables
-# to be unset--not just set to an empty or harmless value--now, to
-# avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct
-# also avoids known problems related to "unset" and subshell syntax
-# in other old shells (e.g. bash 2.01 and pdksh 5.2.14).
-for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH
-do eval test \${$as_var+y} \
- && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :
-done
-
-# Ensure that fds 0, 1, and 2 are open.
-if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi
-if (exec 3>&2) ; then :; else exec 2>/dev/null; fi
-
-# The user is always right.
-if ${PATH_SEPARATOR+false} :; then
- PATH_SEPARATOR=:
- (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {
- (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||
- PATH_SEPARATOR=';'
- }
-fi
-
-
-# Find who we are. Look in the path if we contain no directory separator.
-as_myself=
-case $0 in #((
- *[\\/]* ) as_myself=$0 ;;
- *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- test -r "$as_dir$0" && as_myself=$as_dir$0 && break
- done
-IFS=$as_save_IFS
-
- ;;
-esac
-# We did not find ourselves, most probably we were run as 'sh COMMAND'
-# in which case we are not to be found in the path.
-if test "x$as_myself" = x; then
- as_myself=$0
-fi
-if test ! -f "$as_myself"; then
- printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2
- exit 1
-fi
-
-
-# Use a proper internal environment variable to ensure we don't fall
- # into an infinite loop, continuously re-executing ourselves.
- if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
- _as_can_reexec=no; export _as_can_reexec;
- # We cannot yet assume a decent shell, so we have to provide a
-# neutralization value for shells without unset; and this also
-# works around shells that cannot unset nonexistent variables.
-# Preserve -v and -x to the replacement shell.
-BASH_ENV=/dev/null
-ENV=/dev/null
-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
-case $- in # ((((
- *v*x* | *x*v* ) as_opts=-vx ;;
- *v* ) as_opts=-v ;;
- *x* ) as_opts=-x ;;
- * ) as_opts= ;;
-esac
-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
-# Admittedly, this is quite paranoid, since all the known shells bail
-# out after a failed 'exec'.
-printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
-exit 255
- fi
- # We don't want this to propagate to other subprocesses.
- { _as_can_reexec=; unset _as_can_reexec;}
-if test "x$CONFIG_SHELL" = x; then
- as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1
-then :
- emulate sh
- NULLCMD=:
- # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which
- # is contrary to our usage. Disable this feature.
- alias -g '\${1+\"\$@\"}'='\"\$@\"'
- setopt NO_GLOB_SUBST
-else case e in #(
- e) case \`(set -o) 2>/dev/null\` in #(
- *posix*) :
- set -o posix ;; #(
- *) :
- ;;
-esac ;;
-esac
-fi
-"
- as_required="as_fn_return () { (exit \$1); }
-as_fn_success () { as_fn_return 0; }
-as_fn_failure () { as_fn_return 1; }
-as_fn_ret_success () { return 0; }
-as_fn_ret_failure () { return 1; }
-
-exitcode=0
-as_fn_success || { exitcode=1; echo as_fn_success failed.; }
-as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }
-as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }
-as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }
-if ( set x; as_fn_ret_success y && test x = \"\$1\" )
-then :
-
-else case e in #(
- e) exitcode=1; echo positional parameters were not saved. ;;
-esac
-fi
-test x\$exitcode = x0 || exit 1
-blah=\$(echo \$(echo blah))
-test x\"\$blah\" = xblah || exit 1
-test -x / || exit 1"
- as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
- as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
- eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
- test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1
-test \$(( 1 + 1 )) = 2 || exit 1"
- if (eval "$as_required") 2>/dev/null
-then :
- as_have_required=yes
-else case e in #(
- e) as_have_required=no ;;
-esac
-fi
- if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null
-then :
-
-else case e in #(
- e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-as_found=false
-for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- as_found=:
- case $as_dir in #(
- /*)
- for as_base in sh bash ksh sh5; do
- # Try only shells that exist, to save several forks.
- as_shell=$as_dir$as_base
- if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&
- as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null
-then :
- CONFIG_SHELL=$as_shell as_have_required=yes
- if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null
-then :
- break 2
-fi
-fi
- done;;
- esac
- as_found=false
-done
-IFS=$as_save_IFS
-if $as_found
-then :
-
-else case e in #(
- e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&
- as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null
-then :
- CONFIG_SHELL=$SHELL as_have_required=yes
-fi ;;
-esac
-fi
-
-
- if test "x$CONFIG_SHELL" != x
-then :
- export CONFIG_SHELL
- # We cannot yet assume a decent shell, so we have to provide a
-# neutralization value for shells without unset; and this also
-# works around shells that cannot unset nonexistent variables.
-# Preserve -v and -x to the replacement shell.
-BASH_ENV=/dev/null
-ENV=/dev/null
-(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
-case $- in # ((((
- *v*x* | *x*v* ) as_opts=-vx ;;
- *v* ) as_opts=-v ;;
- *x* ) as_opts=-x ;;
- * ) as_opts= ;;
-esac
-exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
-# Admittedly, this is quite paranoid, since all the known shells bail
-# out after a failed 'exec'.
-printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2
-exit 255
-fi
-
- if test x$as_have_required = xno
-then :
- printf "%s\n" "$0: This script requires a shell more modern than all"
- printf "%s\n" "$0: the shells that I found on your system."
- if test ${ZSH_VERSION+y} ; then
- printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should"
- printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later."
- else
- printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system,
-$0: including any error possibly output before this
-$0: message. Then install a modern shell, or manually run
-$0: the script under such a shell if you do have one."
- fi
- exit 1
-fi ;;
-esac
-fi
-fi
-SHELL=${CONFIG_SHELL-/bin/sh}
-export SHELL
-# Unset more variables known to interfere with behavior of common tools.
-CLICOLOR_FORCE= GREP_OPTIONS=
-unset CLICOLOR_FORCE GREP_OPTIONS
-
-## --------------------- ##
-## M4sh Shell Functions. ##
-## --------------------- ##
-# as_fn_unset VAR
-# ---------------
-# Portably unset VAR.
-as_fn_unset ()
-{
- { eval $1=; unset $1;}
-}
-as_unset=as_fn_unset
-
-
-# as_fn_set_status STATUS
-# -----------------------
-# Set $? to STATUS, without forking.
-as_fn_set_status ()
-{
- return $1
-} # as_fn_set_status
-
-# as_fn_exit STATUS
-# -----------------
-# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.
-as_fn_exit ()
-{
- set +e
- as_fn_set_status $1
- exit $1
-} # as_fn_exit
-
-# as_fn_mkdir_p
-# -------------
-# Create "$as_dir" as a directory, including parents if necessary.
-as_fn_mkdir_p ()
-{
-
- case $as_dir in #(
- -*) as_dir=./$as_dir;;
- esac
- test -d "$as_dir" || eval $as_mkdir_p || {
- as_dirs=
- while :; do
- case $as_dir in #(
- *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(
- *) as_qdir=$as_dir;;
- esac
- as_dirs="'$as_qdir' $as_dirs"
- as_dir=`$as_dirname -- "$as_dir" ||
-$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$as_dir" : 'X\(//\)[^/]' \| \
- X"$as_dir" : 'X\(//\)$' \| \
- X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||
-printf "%s\n" X"$as_dir" |
- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
- s//\1/
- q
- }
- /^X\(\/\/\)[^/].*/{
- s//\1/
- q
- }
- /^X\(\/\/\)$/{
- s//\1/
- q
- }
- /^X\(\/\).*/{
- s//\1/
- q
- }
- s/.*/./; q'`
- test -d "$as_dir" && break
- done
- test -z "$as_dirs" || eval "mkdir $as_dirs"
- } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"
-
-
-} # as_fn_mkdir_p
-
-# as_fn_executable_p FILE
-# -----------------------
-# Test if FILE is an executable regular file.
-as_fn_executable_p ()
-{
- test -f "$1" && test -x "$1"
-} # as_fn_executable_p
-# as_fn_append VAR VALUE
-# ----------------------
-# Append the text in VALUE to the end of the definition contained in VAR. Take
-# advantage of any shell optimizations that allow amortized linear growth over
-# repeated appends, instead of the typical quadratic growth present in naive
-# implementations.
-if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null
-then :
- eval 'as_fn_append ()
- {
- eval $1+=\$2
- }'
-else case e in #(
- e) as_fn_append ()
- {
- eval $1=\$$1\$2
- } ;;
-esac
-fi # as_fn_append
-
-# as_fn_arith ARG...
-# ------------------
-# Perform arithmetic evaluation on the ARGs, and store the result in the
-# global $as_val. Take advantage of shells that can avoid forks. The arguments
-# must be portable across $(()) and expr.
-if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null
-then :
- eval 'as_fn_arith ()
- {
- as_val=$(( $* ))
- }'
-else case e in #(
- e) as_fn_arith ()
- {
- as_val=`expr "$@" || test $? -eq 1`
- } ;;
-esac
-fi # as_fn_arith
-
-
-# as_fn_error STATUS ERROR [LINENO LOG_FD]
-# ----------------------------------------
-# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are
-# provided, also output the error to LOG_FD, referencing LINENO. Then exit the
-# script with STATUS, using 1 if that was 0.
-as_fn_error ()
-{
- as_status=$1; test $as_status -eq 0 && as_status=1
- if test "$4"; then
- as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4
- fi
- printf "%s\n" "$as_me: error: $2" >&2
- as_fn_exit $as_status
-} # as_fn_error
-
-if expr a : '\(a\)' >/dev/null 2>&1 &&
- test "X`expr 00001 : '.*\(...\)'`" = X001; then
- as_expr=expr
-else
- as_expr=false
-fi
-
-if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then
- as_basename=basename
-else
- as_basename=false
-fi
-
-if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then
- as_dirname=dirname
-else
- as_dirname=false
-fi
-
-as_me=`$as_basename -- "$0" ||
-$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
- X"$0" : 'X\(//\)$' \| \
- X"$0" : 'X\(/\)' \| . 2>/dev/null ||
-printf "%s\n" X/"$0" |
- sed '/^.*\/\([^/][^/]*\)\/*$/{
- s//\1/
- q
- }
- /^X\/\(\/\/\)$/{
- s//\1/
- q
- }
- /^X\/\(\/\).*/{
- s//\1/
- q
- }
- s/.*/./; q'`
-
-# Avoid depending upon Character Ranges.
-as_cr_letters='abcdefghijklmnopqrstuvwxyz'
-as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
-as_cr_Letters=$as_cr_letters$as_cr_LETTERS
-as_cr_digits='0123456789'
-as_cr_alnum=$as_cr_Letters$as_cr_digits
-
-
- as_lineno_1=$LINENO as_lineno_1a=$LINENO
- as_lineno_2=$LINENO as_lineno_2a=$LINENO
- eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&
- test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {
- # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)
- sed -n '
- p
- /[$]LINENO/=
- ' <$as_myself |
- sed '
- t clear
- :clear
- s/[$]LINENO.*/&-/
- t lineno
- b
- :lineno
- N
- :loop
- s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/
- t loop
- s/-\n.*//
- ' >$as_me.lineno &&
- chmod +x "$as_me.lineno" ||
- { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
-
- # If we had to re-execute with $CONFIG_SHELL, we're ensured to have
- # already done that, so ensure we don't try to do so again and fall
- # in an infinite loop. This has already happened in practice.
- _as_can_reexec=no; export _as_can_reexec
- # Don't try to exec as it changes $[0], causing all sort of problems
- # (the dirname of $[0] is not the place where we might find the
- # original and so on. Autoconf is especially sensitive to this).
- . "./$as_me.lineno"
- # Exit status is that of the last command.
- exit
-}
-
-
-# Determine whether it's possible to make 'echo' print without a newline.
-# These variables are no longer used directly by Autoconf, but are AC_SUBSTed
-# for compatibility with existing Makefiles.
-ECHO_C= ECHO_N= ECHO_T=
-case `echo -n x` in #(((((
--n*)
- case `echo 'xy\c'` in
- *c*) ECHO_T=' ';; # ECHO_T is single tab character.
- xy) ECHO_C='\c';;
- *) echo `echo ksh88 bug on AIX 6.1` > /dev/null
- ECHO_T=' ';;
- esac;;
-*)
- ECHO_N='-n';;
-esac
-
-# For backward compatibility with old third-party macros, we provide
-# the shell variables $as_echo and $as_echo_n. New code should use
-# AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively.
-as_echo='printf %s\n'
-as_echo_n='printf %s'
-
-rm -f conf$$ conf$$.exe conf$$.file
-if test -d conf$$.dir; then
- rm -f conf$$.dir/conf$$.file
-else
- rm -f conf$$.dir
- mkdir conf$$.dir 2>/dev/null
-fi
-if (echo >conf$$.file) 2>/dev/null; then
- if ln -s conf$$.file conf$$ 2>/dev/null; then
- as_ln_s='ln -s'
- # ... but there are two gotchas:
- # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail.
- # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable.
- # In both cases, we have to default to 'cp -pR'.
- ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
- as_ln_s='cp -pR'
- elif ln conf$$.file conf$$ 2>/dev/null; then
- as_ln_s=ln
- else
- as_ln_s='cp -pR'
- fi
-else
- as_ln_s='cp -pR'
-fi
-rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
-rmdir conf$$.dir 2>/dev/null
-
-if mkdir -p . 2>/dev/null; then
- as_mkdir_p='mkdir -p "$as_dir"'
-else
- test -d ./-p && rmdir ./-p
- as_mkdir_p=false
-fi
-
-as_test_x='test -x'
-as_executable_p=as_fn_executable_p
-
-# Sed expression to map a string onto a valid CPP name.
-as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g"
-as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated
-
-# Sed expression to map a string onto a valid variable name.
-as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g"
-as_tr_sh="eval sed '$as_sed_sh'" # deprecated
-
-
-test -n "$DJDIR" || exec 7<&0 &1
-
-# Name of the host.
-# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status,
-# so uname gets run too.
-ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
-
-#
-# Initializations.
-#
-ac_default_prefix=/usr/local
-ac_clean_files=
-ac_config_libobj_dir=.
-LIBOBJS=
-cross_compiling=no
-subdirs=
-MFLAGS=
-MAKEFLAGS=
-
-# Identity of this package.
-PACKAGE_NAME='tcl'
-PACKAGE_TARNAME='tcl'
-PACKAGE_VERSION='9.0'
-PACKAGE_STRING='tcl 9.0'
-PACKAGE_BUGREPORT=''
-PACKAGE_URL=''
-
-# Factoring default headers for most tests.
-ac_includes_default="\
-#include
-#ifdef HAVE_STDIO_H
-# include
-#endif
-#ifdef HAVE_STDLIB_H
-# include
-#endif
-#ifdef HAVE_STRING_H
-# include
-#endif
-#ifdef HAVE_INTTYPES_H
-# include
-#endif
-#ifdef HAVE_STDINT_H
-# include
-#endif
-#ifdef HAVE_STRINGS_H
-# include
-#endif
-#ifdef HAVE_SYS_TYPES_H
-# include
-#endif
-#ifdef HAVE_SYS_STAT_H
-# include
-#endif
-#ifdef HAVE_UNISTD_H
-# include
-#endif"
-
-ac_header_c_list=
-ac_subst_vars='DLTEST_SUFFIX
-DLTEST_LD
-EXTRA_TCLSH_LIBS
-EXTRA_BUILD_HTML
-EXTRA_INSTALL_BINARIES
-EXTRA_INSTALL
-EXTRA_APP_CC_SWITCHES
-EXTRA_CC_SWITCHES
-PACKAGE_DIR
-HTML_DIR
-PRIVATE_INCLUDE_DIR
-TCL_LIBRARY
-TCL_MODULE_PATH
-TCL_PACKAGE_PATH
-BUILD_DLTEST
-MAKEFILE_SHELL
-DTRACE_OBJ
-DTRACE_HDR
-DTRACE_SRC
-INSTALL_TZDATA
-TCL_HAS_LONGLONG
-TCL_UNSHARED_LIB_SUFFIX
-TCL_SHARED_LIB_SUFFIX
-TCL_LIB_VERSIONS_OK
-TCL_BUILD_LIB_SPEC
-LD_LIBRARY_PATH_VAR
-TCL_SHARED_BUILD
-CFG_TCL_UNSHARED_LIB_SUFFIX
-CFG_TCL_SHARED_LIB_SUFFIX
-TCL_SRC_DIR
-TCL_BUILD_STUB_LIB_PATH
-TCL_BUILD_STUB_LIB_SPEC
-TCL_INCLUDE_SPEC
-TCL_STUB_LIB_PATH
-TCL_STUB_LIB_SPEC
-TCL_STUB_LIB_FLAG
-TCL_STUB_LIB_FILE
-TCL_LIB_SPEC
-TCL_LIB_FLAG
-TCL_LIB_FILE
-PKG_CFG_ARGS
-TCL_YEAR
-TCL_PATCH_LEVEL
-TCL_MINOR_VERSION
-TCL_MAJOR_VERSION
-TCL_VERSION
-TCL_BUILDTIME_LIBRARY
-INSTALL_MSGS
-INSTALL_LIBRARIES
-TCL_ZIP_FILE
-ZIPFS_BUILD
-ZIP_INSTALL_OBJS
-ZIP_PROG_VFSSEARCH
-ZIP_PROG_OPTIONS
-ZIP_PROG
-MACHER_PROG
-EXEEXT_FOR_BUILD
-CC_FOR_BUILD
-DTRACE
-LDFLAGS_DEFAULT
-CFLAGS_DEFAULT
-INSTALL_STUB_LIB
-DLL_INSTALL_DIR
-INSTALL_LIB
-MAKE_STUB_LIB
-MAKE_LIB
-SHLIB_SUFFIX
-SHLIB_CFLAGS
-SHLIB_LD_LIBS
-TK_SHLIB_LD_EXTRAS
-TCL_SHLIB_LD_EXTRAS
-SHLIB_LD
-STLIB_LD
-LD_SEARCH_FLAGS
-CC_SEARCH_FLAGS
-LDFLAGS_OPTIMIZE
-LDFLAGS_DEBUG
-CFLAGS_NOLTO
-CFLAGS_WARNING
-CFLAGS_OPTIMIZE
-CFLAGS_DEBUG
-LDAIX_SRC
-PLAT_SRCS
-PLAT_OBJS
-DL_OBJS
-DL_LIBS
-TCL_LIBS
-LIBOBJS
-AR
-RANLIB
-TOMMATH_INCLUDE
-TOMMATH_SRCS
-TOMMATH_OBJS
-TCL_PC_CFLAGS
-TCL_PC_REQUIRES_PRIVATE
-ZLIB_INCLUDE
-ZLIB_SRCS
-ZLIB_OBJS
-TCLSH_PROG
-SHARED_BUILD
-CPP
-OBJEXT
-EXEEXT
-ac_ct_CC
-CPPFLAGS
-LDFLAGS
-CFLAGS
-CC
-MAN_FLAGS
-target_alias
-host_alias
-build_alias
-LIBS
-ECHO_T
-ECHO_N
-ECHO_C
-DEFS
-mandir
-localedir
-libdir
-psdir
-pdfdir
-dvidir
-htmldir
-infodir
-docdir
-oldincludedir
-includedir
-runstatedir
-localstatedir
-sharedstatedir
-sysconfdir
-datadir
-datarootdir
-libexecdir
-sbindir
-bindir
-program_transform_name
-prefix
-exec_prefix
-PACKAGE_URL
-PACKAGE_BUGREPORT
-PACKAGE_STRING
-PACKAGE_VERSION
-PACKAGE_TARNAME
-PACKAGE_NAME
-PATH_SEPARATOR
-SHELL
-OBJEXT_FOR_BUILD'
-ac_subst_files=''
-ac_user_opts='
-enable_option_checking
-enable_man_symlinks
-enable_man_compression
-enable_man_suffix
-with_encoding
-enable_shared
-with_system_libtommath
-enable_64bit
-enable_64bit_vis
-enable_rpath
-enable_corefoundation
-enable_load
-enable_symbols
-enable_langinfo
-enable_dll_unloading
-with_tzdata
-enable_dtrace
-enable_framework
-enable_zipfs
-'
- ac_precious_vars='build_alias
-host_alias
-target_alias
-CC
-CFLAGS
-LDFLAGS
-LIBS
-CPPFLAGS
-CPP'
-
-
-# Initialize some variables set by options.
-ac_init_help=
-ac_init_version=false
-ac_unrecognized_opts=
-ac_unrecognized_sep=
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-cache_file=/dev/null
-exec_prefix=NONE
-no_create=
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-verbose=
-x_includes=NONE
-x_libraries=NONE
-
-# Installation directory options.
-# These are left unexpanded so users can "make install exec_prefix=/foo"
-# and all the variables that are supposed to be based on exec_prefix
-# by default will actually change.
-# Use braces instead of parens because sh, perl, etc. also accept them.
-# (The list follows the same order as the GNU Coding Standards.)
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datarootdir='${prefix}/share'
-datadir='${datarootdir}'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-runstatedir='${localstatedir}/run'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
-infodir='${datarootdir}/info'
-htmldir='${docdir}'
-dvidir='${docdir}'
-pdfdir='${docdir}'
-psdir='${docdir}'
-libdir='${exec_prefix}/lib'
-localedir='${datarootdir}/locale'
-mandir='${datarootdir}/man'
-
-ac_prev=
-ac_dashdash=
-for ac_option
-do
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval $ac_prev=\$ac_option
- ac_prev=
- continue
- fi
-
- case $ac_option in
- *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;
- *=) ac_optarg= ;;
- *) ac_optarg=yes ;;
- esac
-
- case $ac_dashdash$ac_option in
- --)
- ac_dashdash=yes ;;
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir=$ac_optarg ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build_alias ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build_alias=$ac_optarg ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file=$ac_optarg ;;
-
- --config-cache | -C)
- cache_file=config.cache ;;
-
- -datadir | --datadir | --datadi | --datad)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=*)
- datadir=$ac_optarg ;;
-
- -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \
- | --dataroo | --dataro | --datar)
- ac_prev=datarootdir ;;
- -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \
- | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)
- datarootdir=$ac_optarg ;;
-
- -disable-* | --disable-*)
- ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
- as_fn_error $? "invalid feature name: '$ac_useropt'"
- ac_useropt_orig=$ac_useropt
- ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
- case $ac_user_opts in
- *"
-"enable_$ac_useropt"
-"*) ;;
- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"
- ac_unrecognized_sep=', ';;
- esac
- eval enable_$ac_useropt=no ;;
-
- -docdir | --docdir | --docdi | --doc | --do)
- ac_prev=docdir ;;
- -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)
- docdir=$ac_optarg ;;
-
- -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)
- ac_prev=dvidir ;;
- -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)
- dvidir=$ac_optarg ;;
-
- -enable-* | --enable-*)
- ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
- as_fn_error $? "invalid feature name: '$ac_useropt'"
- ac_useropt_orig=$ac_useropt
- ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
- case $ac_user_opts in
- *"
-"enable_$ac_useropt"
-"*) ;;
- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"
- ac_unrecognized_sep=', ';;
- esac
- eval enable_$ac_useropt=\$ac_optarg ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix=$ac_optarg ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he | -h)
- ac_init_help=long ;;
- -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
- ac_init_help=recursive ;;
- -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
- ac_init_help=short ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host_alias ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host_alias=$ac_optarg ;;
-
- -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)
- ac_prev=htmldir ;;
- -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \
- | --ht=*)
- htmldir=$ac_optarg ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir=$ac_optarg ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir=$ac_optarg ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir=$ac_optarg ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir=$ac_optarg ;;
-
- -localedir | --localedir | --localedi | --localed | --locale)
- ac_prev=localedir ;;
- -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)
- localedir=$ac_optarg ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst | --locals)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)
- localstatedir=$ac_optarg ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir=$ac_optarg ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c | -n)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir=$ac_optarg ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix=$ac_optarg ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix=$ac_optarg ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix=$ac_optarg ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name=$ac_optarg ;;
-
- -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)
- ac_prev=pdfdir ;;
- -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)
- pdfdir=$ac_optarg ;;
-
- -psdir | --psdir | --psdi | --psd | --ps)
- ac_prev=psdir ;;
- -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)
- psdir=$ac_optarg ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -runstatedir | --runstatedir | --runstatedi | --runstated \
- | --runstate | --runstat | --runsta | --runst | --runs \
- | --run | --ru | --r)
- ac_prev=runstatedir ;;
- -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
- | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
- | --run=* | --ru=* | --r=*)
- runstatedir=$ac_optarg ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir=$ac_optarg ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir=$ac_optarg ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site=$ac_optarg ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir=$ac_optarg ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir=$ac_optarg ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target_alias ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target_alias=$ac_optarg ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers | -V)
- ac_init_version=: ;;
-
- -with-* | --with-*)
- ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
- as_fn_error $? "invalid package name: '$ac_useropt'"
- ac_useropt_orig=$ac_useropt
- ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
- case $ac_user_opts in
- *"
-"with_$ac_useropt"
-"*) ;;
- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"
- ac_unrecognized_sep=', ';;
- esac
- eval with_$ac_useropt=\$ac_optarg ;;
-
- -without-* | --without-*)
- ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`
- # Reject names that are not valid shell variable names.
- expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&
- as_fn_error $? "invalid package name: '$ac_useropt'"
- ac_useropt_orig=$ac_useropt
- ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'`
- case $ac_user_opts in
- *"
-"with_$ac_useropt"
-"*) ;;
- *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"
- ac_unrecognized_sep=', ';;
- esac
- eval with_$ac_useropt=no ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes=$ac_optarg ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries=$ac_optarg ;;
-
- -*) as_fn_error $? "unrecognized option: '$ac_option'
-Try '$0 --help' for more information"
- ;;
-
- *=*)
- ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
- # Reject names that are not valid shell variable names.
- case $ac_envvar in #(
- '' | [0-9]* | *[!_$as_cr_alnum]* )
- as_fn_error $? "invalid variable name: '$ac_envvar'" ;;
- esac
- eval $ac_envvar=\$ac_optarg
- export $ac_envvar ;;
-
- *)
- # FIXME: should be removed in autoconf 3.0.
- printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2
- expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
- printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2
- : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- ac_option=--`echo $ac_prev | sed 's/_/-/g'`
- as_fn_error $? "missing argument to $ac_option"
-fi
-
-if test -n "$ac_unrecognized_opts"; then
- case $enable_option_checking in
- no) ;;
- fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;
- *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;
- esac
-fi
-
-# Check all directory arguments for consistency.
-for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
- datadir sysconfdir sharedstatedir localstatedir includedir \
- oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
- libdir localedir mandir runstatedir
-do
- eval ac_val=\$$ac_var
- # Remove trailing slashes.
- case $ac_val in
- */ )
- ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`
- eval $ac_var=\$ac_val;;
- esac
- # Be sure to have absolute directory names.
- case $ac_val in
- [\\/$]* | ?:[\\/]* ) continue;;
- NONE | '' ) case $ac_var in *prefix ) continue;; esac;;
- esac
- as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"
-done
-
-# There might be people who depend on the old broken behavior: '$host'
-# used to hold the argument of --host etc.
-# FIXME: To remove some day.
-build=$build_alias
-host=$host_alias
-target=$target_alias
-
-# FIXME: To remove some day.
-if test "x$host_alias" != x; then
- if test "x$build_alias" = x; then
- cross_compiling=maybe
- elif test "x$build_alias" != "x$host_alias"; then
- cross_compiling=yes
- fi
-fi
-
-ac_tool_prefix=
-test -n "$host_alias" && ac_tool_prefix=$host_alias-
-
-test "$silent" = yes && exec 6>/dev/null
-
-
-ac_pwd=`pwd` && test -n "$ac_pwd" &&
-ac_ls_di=`ls -di .` &&
-ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||
- as_fn_error $? "working directory cannot be determined"
-test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||
- as_fn_error $? "pwd does not report name of working directory"
-
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then the parent directory.
- ac_confdir=`$as_dirname -- "$as_myself" ||
-$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
- X"$as_myself" : 'X\(//\)[^/]' \| \
- X"$as_myself" : 'X\(//\)$' \| \
- X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||
-printf "%s\n" X"$as_myself" |
- sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
- s//\1/
- q
- }
- /^X\(\/\/\)[^/].*/{
- s//\1/
- q
- }
- /^X\(\/\/\)$/{
- s//\1/
- q
- }
- /^X\(\/\).*/{
- s//\1/
- q
- }
- s/.*/./; q'`
- srcdir=$ac_confdir
- if test ! -r "$srcdir/$ac_unique_file"; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r "$srcdir/$ac_unique_file"; then
- test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."
- as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"
-fi
-ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work"
-ac_abs_confdir=`(
- cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"
- pwd)`
-# When building in place, set srcdir=.
-if test "$ac_abs_confdir" = "$ac_pwd"; then
- srcdir=.
-fi
-# Remove unnecessary trailing slashes from srcdir.
-# Double slashes in file names in object file debugging info
-# mess up M-x gdb in Emacs.
-case $srcdir in
-*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;
-esac
-for ac_var in $ac_precious_vars; do
- eval ac_env_${ac_var}_set=\${${ac_var}+set}
- eval ac_env_${ac_var}_value=\$${ac_var}
- eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}
- eval ac_cv_env_${ac_var}_value=\$${ac_var}
-done
-
-#
-# Report the --help message.
-#
-if test "$ac_init_help" = "long"; then
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat <<_ACEOF
-'configure' configures tcl 9.0 to adapt to many kinds of systems.
-
-Usage: $0 [OPTION]... [VAR=VALUE]...
-
-To assign environment variables (e.g., CC, CFLAGS...), specify them as
-VAR=VALUE. See below for descriptions of some of the useful variables.
-
-Defaults for the options are specified in brackets.
-
-Configuration:
- -h, --help display this help and exit
- --help=short display options specific to this package
- --help=recursive display the short help of all the included packages
- -V, --version display version information and exit
- -q, --quiet, --silent do not print 'checking ...' messages
- --cache-file=FILE cache test results in FILE [disabled]
- -C, --config-cache alias for '--cache-file=config.cache'
- -n, --no-create do not create output files
- --srcdir=DIR find the sources in DIR [configure dir or '..']
-
-Installation directories:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [PREFIX]
-
-By default, 'make install' will install all the files in
-'$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify
-an installation prefix other than '$ac_default_prefix' using '--prefix',
-for instance '--prefix=\$HOME'.
-
-For better control, use the options below.
-
-Fine tuning of the installation directories:
- --bindir=DIR user executables [EPREFIX/bin]
- --sbindir=DIR system admin executables [EPREFIX/sbin]
- --libexecdir=DIR program executables [EPREFIX/libexec]
- --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data [PREFIX/var]
- --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
- --libdir=DIR object code libraries [EPREFIX/lib]
- --includedir=DIR C header files [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc [/usr/include]
- --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]
- --datadir=DIR read-only architecture-independent data [DATAROOTDIR]
- --infodir=DIR info documentation [DATAROOTDIR/info]
- --localedir=DIR locale-dependent data [DATAROOTDIR/locale]
- --mandir=DIR man documentation [DATAROOTDIR/man]
- --docdir=DIR documentation root [DATAROOTDIR/doc/tcl]
- --htmldir=DIR html documentation [DOCDIR]
- --dvidir=DIR dvi documentation [DOCDIR]
- --pdfdir=DIR pdf documentation [DOCDIR]
- --psdir=DIR ps documentation [DOCDIR]
-_ACEOF
-
- cat <<\_ACEOF
-_ACEOF
-fi
-
-if test -n "$ac_init_help"; then
- case $ac_init_help in
- short | recursive ) echo "Configuration of tcl 9.0:";;
- esac
- cat <<\_ACEOF
-
-Optional Features:
- --disable-option-checking ignore unrecognized --enable/--with options
- --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
- --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --enable-man-symlinks use symlinks for the manpages (default: off)
- --enable-man-compression=PROG
- compress the manpages with PROG (default: off)
- --enable-man-suffix=STRING
- use STRING as a suffix to manpage file names
- (default: no, tcl if enabled without
- specifying STRING)
- --enable-shared build and link with shared libraries (default: on)
- --enable-64bit enable 64bit support (default: off)
- --enable-64bit-vis enable 64bit Sparc VIS support (default: off)
- --disable-rpath disable rpath support (default: on)
- --enable-corefoundation use CoreFoundation API on MacOSX (default: on)
- --enable-load allow dynamic loading and "load" command (default:
- on)
- --enable-symbols build with debugging symbols (default: off)
- --enable-langinfo use nl_langinfo if possible to determine encoding at
- startup, otherwise use old heuristic (default: on)
- --enable-dll-unloading enable the 'unload' command (default: on)
- --enable-dtrace build with DTrace support (default: off)
- --enable-framework package shared libraries in MacOSX frameworks
- (default: off)
- --enable-zipfs build with Zipfs support (default: on)
-
-Optional Packages:
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --with-encoding encoding for configuration values (default: utf-8)
- --with-system-libtommath
- use external libtommath (default: true if available,
- false otherwise)
- --with-tzdata install timezone data (default: autodetect)
-
-Some influential environment variables:
- CC C compiler command
- CFLAGS C compiler flags
- LDFLAGS linker flags, e.g. -L if you have libraries in a
- nonstandard directory
- LIBS libraries to pass to the linker, e.g. -l
- CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if
- you have headers in a nonstandard directory
- CPP C preprocessor
-
-Use these variables to override the choices made by 'configure' or to help
-it to find libraries and programs with nonstandard names/locations.
-
-Report bugs to the package provider.
-_ACEOF
-ac_status=$?
-fi
-
-if test "$ac_init_help" = "recursive"; then
- # If there are subdirs, report their specific --help.
- for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
- test -d "$ac_dir" ||
- { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||
- continue
- ac_builddir=.
-
-case "$ac_dir" in
-.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;
-*)
- ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'`
- # A ".." for each directory in $ac_dir_suffix.
- ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`
- case $ac_top_builddir_sub in
- "") ac_top_builddir_sub=. ac_top_build_prefix= ;;
- *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;
- esac ;;
-esac
-ac_abs_top_builddir=$ac_pwd
-ac_abs_builddir=$ac_pwd$ac_dir_suffix
-# for backward compatibility:
-ac_top_builddir=$ac_top_build_prefix
-
-case $srcdir in
- .) # We are building in place.
- ac_srcdir=.
- ac_top_srcdir=$ac_top_builddir_sub
- ac_abs_top_srcdir=$ac_pwd ;;
- [\\/]* | ?:[\\/]* ) # Absolute name.
- ac_srcdir=$srcdir$ac_dir_suffix;
- ac_top_srcdir=$srcdir
- ac_abs_top_srcdir=$srcdir ;;
- *) # Relative name.
- ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix
- ac_top_srcdir=$ac_top_build_prefix$srcdir
- ac_abs_top_srcdir=$ac_pwd/$srcdir ;;
-esac
-ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix
-
- cd "$ac_dir" || { ac_status=$?; continue; }
- # Check for configure.gnu first; this name is used for a wrapper for
- # Metaconfig's "Configure" on case-insensitive file systems.
- if test -f "$ac_srcdir/configure.gnu"; then
- echo &&
- $SHELL "$ac_srcdir/configure.gnu" --help=recursive
- elif test -f "$ac_srcdir/configure"; then
- echo &&
- $SHELL "$ac_srcdir/configure" --help=recursive
- else
- printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2
- fi || ac_status=$?
- cd "$ac_pwd" || { ac_status=$?; break; }
- done
-fi
-
-test -n "$ac_init_help" && exit $ac_status
-if $ac_init_version; then
- cat <<\_ACEOF
-tcl configure 9.0
-generated by GNU Autoconf 2.72
-
-Copyright (C) 2023 Free Software Foundation, Inc.
-This configure script is free software; the Free Software Foundation
-gives unlimited permission to copy, distribute and modify it.
-_ACEOF
- exit
-fi
-
-## ------------------------ ##
-## Autoconf initialization. ##
-## ------------------------ ##
-
-# ac_fn_c_try_compile LINENO
-# --------------------------
-# Try to compile conftest.$ac_ext, and return whether this succeeded.
-ac_fn_c_try_compile ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- rm -f conftest.$ac_objext conftest.beam
- if { { ac_try="$ac_compile"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_compile") 2>conftest.err
- ac_status=$?
- if test -s conftest.err; then
- grep -v '^ *+' conftest.err >conftest.er1
- cat conftest.er1 >&5
- mv -f conftest.er1 conftest.err
- fi
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; } && {
- test -z "$ac_c_werror_flag" ||
- test ! -s conftest.err
- } && test -s conftest.$ac_objext
-then :
- ac_retval=0
-else case e in #(
- e) printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_retval=1 ;;
-esac
-fi
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
- as_fn_set_status $ac_retval
-
-} # ac_fn_c_try_compile
-
-# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
-# -------------------------------------------------------
-# Tests whether HEADER exists and can be compiled using the include files in
-# INCLUDES, setting the cache variable VAR accordingly.
-ac_fn_c_check_header_compile ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
-printf %s "checking for $2... " >&6; }
-if eval test \${$3+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$4
-#include <$2>
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- eval "$3=yes"
-else case e in #(
- e) eval "$3=no" ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-eval ac_res=\$$3
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
-printf "%s\n" "$ac_res" >&6; }
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
-
-} # ac_fn_c_check_header_compile
-
-# ac_fn_c_try_cpp LINENO
-# ----------------------
-# Try to preprocess conftest.$ac_ext, and return whether this succeeded.
-ac_fn_c_try_cpp ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- if { { ac_try="$ac_cpp conftest.$ac_ext"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err
- ac_status=$?
- if test -s conftest.err; then
- grep -v '^ *+' conftest.err >conftest.er1
- cat conftest.er1 >&5
- mv -f conftest.er1 conftest.err
- fi
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; } > conftest.i && {
- test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" ||
- test ! -s conftest.err
- }
-then :
- ac_retval=0
-else case e in #(
- e) printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_retval=1 ;;
-esac
-fi
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
- as_fn_set_status $ac_retval
-
-} # ac_fn_c_try_cpp
-
-# ac_fn_c_try_link LINENO
-# -----------------------
-# Try to link conftest.$ac_ext, and return whether this succeeded.
-ac_fn_c_try_link ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext
- if { { ac_try="$ac_link"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_link") 2>conftest.err
- ac_status=$?
- if test -s conftest.err; then
- grep -v '^ *+' conftest.err >conftest.er1
- cat conftest.er1 >&5
- mv -f conftest.er1 conftest.err
- fi
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; } && {
- test -z "$ac_c_werror_flag" ||
- test ! -s conftest.err
- } && test -s conftest$ac_exeext && {
- test "$cross_compiling" = yes ||
- test -x conftest$ac_exeext
- }
-then :
- ac_retval=0
-else case e in #(
- e) printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_retval=1 ;;
-esac
-fi
- # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information
- # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would
- # interfere with the next link command; also delete a directory that is
- # left behind by Apple's compiler. We do this before executing the actions.
- rm -rf conftest.dSYM conftest_ipa8_conftest.oo
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
- as_fn_set_status $ac_retval
-
-} # ac_fn_c_try_link
-
-# ac_fn_c_check_func LINENO FUNC VAR
-# ----------------------------------
-# Tests whether FUNC exists, setting the cache variable VAR accordingly
-ac_fn_c_check_func ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
-printf %s "checking for $2... " >&6; }
-if eval test \${$3+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-/* Define $2 to an innocuous variant, in case declares $2.
- For example, HP-UX 11i declares gettimeofday. */
-#define $2 innocuous_$2
-
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $2 (void); below. */
-
-#include
-#undef $2
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply. */
-#ifdef __cplusplus
-extern "C"
-#endif
-char $2 (void);
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined __stub_$2 || defined __stub___$2
-choke me
-#endif
-
-int
-main (void)
-{
-return $2 ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- eval "$3=yes"
-else case e in #(
- e) eval "$3=no" ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext ;;
-esac
-fi
-eval ac_res=\$$3
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
-printf "%s\n" "$ac_res" >&6; }
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
-
-} # ac_fn_c_check_func
-
-# ac_fn_check_decl LINENO SYMBOL VAR INCLUDES EXTRA-OPTIONS FLAG-VAR
-# ------------------------------------------------------------------
-# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR
-# accordingly. Pass EXTRA-OPTIONS to the compiler, using FLAG-VAR.
-ac_fn_check_decl ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- as_decl_name=`echo $2|sed 's/ *(.*//'`
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5
-printf %s "checking whether $as_decl_name is declared... " >&6; }
-if eval test \${$3+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`
- eval ac_save_FLAGS=\$$6
- as_fn_append $6 " $5"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$4
-int
-main (void)
-{
-#ifndef $as_decl_name
-#ifdef __cplusplus
- (void) $as_decl_use;
-#else
- (void) $as_decl_name;
-#endif
-#endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- eval "$3=yes"
-else case e in #(
- e) eval "$3=no" ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- eval $6=\$ac_save_FLAGS
- ;;
-esac
-fi
-eval ac_res=\$$3
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
-printf "%s\n" "$ac_res" >&6; }
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
-
-} # ac_fn_check_decl
-
-# ac_fn_c_check_type LINENO TYPE VAR INCLUDES
-# -------------------------------------------
-# Tests whether TYPE exists after having included INCLUDES, setting cache
-# variable VAR accordingly.
-ac_fn_c_check_type ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
-printf %s "checking for $2... " >&6; }
-if eval test \${$3+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) eval "$3=no"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$4
-int
-main (void)
-{
-if (sizeof ($2))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$4
-int
-main (void)
-{
-if (sizeof (($2)))
- return 0;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
-
-else case e in #(
- e) eval "$3=yes" ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-eval ac_res=\$$3
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
-printf "%s\n" "$ac_res" >&6; }
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
-
-} # ac_fn_c_check_type
-
-# ac_fn_c_try_run LINENO
-# ----------------------
-# Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that
-# executables *can* be run.
-ac_fn_c_try_run ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- if { { ac_try="$ac_link"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_link") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; } && { ac_try='./conftest$ac_exeext'
- { { case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_try") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }; }
-then :
- ac_retval=0
-else case e in #(
- e) printf "%s\n" "$as_me: program exited with status $ac_status" >&5
- printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
- ac_retval=$ac_status ;;
-esac
-fi
- rm -rf conftest.dSYM conftest_ipa8_conftest.oo
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
- as_fn_set_status $ac_retval
-
-} # ac_fn_c_try_run
-
-# ac_fn_c_check_member LINENO AGGR MEMBER VAR INCLUDES
-# ----------------------------------------------------
-# Tries to find if the field MEMBER exists in type AGGR, after including
-# INCLUDES, setting cache variable VAR accordingly.
-ac_fn_c_check_member ()
-{
- as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2.$3" >&5
-printf %s "checking for $2.$3... " >&6; }
-if eval test \${$4+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$5
-int
-main (void)
-{
-static $2 ac_aggr;
-if (ac_aggr.$3)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- eval "$4=yes"
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$5
-int
-main (void)
-{
-static $2 ac_aggr;
-if (sizeof ac_aggr.$3)
-return 0;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- eval "$4=yes"
-else case e in #(
- e) eval "$4=no" ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-eval ac_res=\$$4
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
-printf "%s\n" "$ac_res" >&6; }
- eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
-
-} # ac_fn_c_check_member
-ac_configure_args_raw=
-for ac_arg
-do
- case $ac_arg in
- *\'*)
- ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
- esac
- as_fn_append ac_configure_args_raw " '$ac_arg'"
-done
-
-case $ac_configure_args_raw in
- *$as_nl*)
- ac_safe_unquote= ;;
- *)
- ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab.
- ac_unsafe_a="$ac_unsafe_z#~"
- ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g"
- ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;;
-esac
-
-cat >config.log <<_ACEOF
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-
-It was created by tcl $as_me 9.0, which was
-generated by GNU Autoconf 2.72. Invocation command line was
-
- $ $0$ac_configure_args_raw
-
-_ACEOF
-exec 5>>config.log
-{
-cat <<_ASUNAME
-## --------- ##
-## Platform. ##
-## --------- ##
-
-hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
-uname -m = `(uname -m) 2>/dev/null || echo unknown`
-uname -r = `(uname -r) 2>/dev/null || echo unknown`
-uname -s = `(uname -s) 2>/dev/null || echo unknown`
-uname -v = `(uname -v) 2>/dev/null || echo unknown`
-
-/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
-/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
-
-/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
-/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
-/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
-/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`
-/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
-/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
-/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
-
-_ASUNAME
-
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- printf "%s\n" "PATH: $as_dir"
- done
-IFS=$as_save_IFS
-
-} >&5
-
-cat >&5 <<_ACEOF
-
-
-## ----------- ##
-## Core tests. ##
-## ----------- ##
-
-_ACEOF
-
-
-# Keep a trace of the command line.
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Strip out --silent because we don't want to record it for future runs.
-# Also quote any args containing shell meta-characters.
-# Make two passes to allow for proper duplicate-argument suppression.
-ac_configure_args=
-ac_configure_args0=
-ac_configure_args1=
-ac_must_keep_next=false
-for ac_pass in 1 2
-do
- for ac_arg
- do
- case $ac_arg in
- -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- continue ;;
- *\'*)
- ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
- esac
- case $ac_pass in
- 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;
- 2)
- as_fn_append ac_configure_args1 " '$ac_arg'"
- if test $ac_must_keep_next = true; then
- ac_must_keep_next=false # Got value, back to normal.
- else
- case $ac_arg in
- *=* | --config-cache | -C | -disable-* | --disable-* \
- | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
- | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
- | -with-* | --with-* | -without-* | --without-* | --x)
- case "$ac_configure_args0 " in
- "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
- esac
- ;;
- -* ) ac_must_keep_next=true ;;
- esac
- fi
- as_fn_append ac_configure_args " '$ac_arg'"
- ;;
- esac
- done
-done
-{ ac_configure_args0=; unset ac_configure_args0;}
-{ ac_configure_args1=; unset ac_configure_args1;}
-
-# When interrupted or exit'd, cleanup temporary files, and complete
-# config.log. We remove comments because anyway the quotes in there
-# would cause problems or look ugly.
-# WARNING: Use '\'' to represent an apostrophe within the trap.
-# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.
-trap 'exit_status=$?
- # Sanitize IFS.
- IFS=" "" $as_nl"
- # Save into config.log some information that might help in debugging.
- {
- echo
-
- printf "%s\n" "## ---------------- ##
-## Cache variables. ##
-## ---------------- ##"
- echo
- # The following way of writing the cache mishandles newlines in values,
-(
- for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do
- eval ac_val=\$$ac_var
- case $ac_val in #(
- *${as_nl}*)
- case $ac_var in #(
- *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5
-printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;
- esac
- case $ac_var in #(
- _ | IFS | as_nl) ;; #(
- BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(
- *) { eval $ac_var=; unset $ac_var;} ;;
- esac ;;
- esac
- done
- (set) 2>&1 |
- case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(
- *${as_nl}ac_space=\ *)
- sed -n \
- "s/'\''/'\''\\\\'\'''\''/g;
- s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"
- ;; #(
- *)
- sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"
- ;;
- esac |
- sort
-)
- echo
-
- printf "%s\n" "## ----------------- ##
-## Output variables. ##
-## ----------------- ##"
- echo
- for ac_var in $ac_subst_vars
- do
- eval ac_val=\$$ac_var
- case $ac_val in
- *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
- esac
- printf "%s\n" "$ac_var='\''$ac_val'\''"
- done | sort
- echo
-
- if test -n "$ac_subst_files"; then
- printf "%s\n" "## ------------------- ##
-## File substitutions. ##
-## ------------------- ##"
- echo
- for ac_var in $ac_subst_files
- do
- eval ac_val=\$$ac_var
- case $ac_val in
- *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;
- esac
- printf "%s\n" "$ac_var='\''$ac_val'\''"
- done | sort
- echo
- fi
-
- if test -s confdefs.h; then
- printf "%s\n" "## ----------- ##
-## confdefs.h. ##
-## ----------- ##"
- echo
- cat confdefs.h
- echo
- fi
- test "$ac_signal" != 0 &&
- printf "%s\n" "$as_me: caught signal $ac_signal"
- printf "%s\n" "$as_me: exit $exit_status"
- } >&5
- rm -f core *.core core.conftest.* &&
- rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&
- exit $exit_status
-' 0
-for ac_signal in 1 2 13 15; do
- trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal
-done
-ac_signal=0
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -f -r conftest* confdefs.h
-
-printf "%s\n" "/* confdefs.h */" > confdefs.h
-
-# Predefined preprocessor variables.
-
-printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h
-
-printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h
-
-printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h
-
-printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h
-
-printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h
-
-printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h
-
-
-# Let the site file select an alternate cache file if it wants to.
-# Prefer an explicitly selected file to automatically selected ones.
-if test -n "$CONFIG_SITE"; then
- ac_site_files="$CONFIG_SITE"
-elif test "x$prefix" != xNONE; then
- ac_site_files="$prefix/share/config.site $prefix/etc/config.site"
-else
- ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
-fi
-
-for ac_site_file in $ac_site_files
-do
- case $ac_site_file in #(
- */*) :
- ;; #(
- *) :
- ac_site_file=./$ac_site_file ;;
-esac
- if test -f "$ac_site_file" && test -r "$ac_site_file"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5
-printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;}
- sed 's/^/| /' "$ac_site_file" >&5
- . "$ac_site_file" \
- || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "failed to load site script $ac_site_file
-See 'config.log' for more details" "$LINENO" 5; }
- fi
-done
-
-if test -r "$cache_file"; then
- # Some versions of bash will fail to source /dev/null (special files
- # actually), so we avoid doing that. DJGPP emulates it as a regular file.
- if test /dev/null != "$cache_file" && test -f "$cache_file"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5
-printf "%s\n" "$as_me: loading cache $cache_file" >&6;}
- case $cache_file in
- [\\/]* | ?:[\\/]* ) . "$cache_file";;
- *) . "./$cache_file";;
- esac
- fi
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5
-printf "%s\n" "$as_me: creating cache $cache_file" >&6;}
- >$cache_file
-fi
-
-# Test code for whether the C compiler supports C89 (global declarations)
-ac_c_conftest_c89_globals='
-/* Does the compiler advertise C89 conformance?
- Do not test the value of __STDC__, because some compilers set it to 0
- while being otherwise adequately conformant. */
-#if !defined __STDC__
-# error "Compiler does not advertise C89 conformance"
-#endif
-
-#include
-#include
-struct stat;
-/* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */
-struct buf { int x; };
-struct buf * (*rcsopen) (struct buf *, struct stat *, int);
-static char *e (char **p, int i)
-{
- return p[i];
-}
-static char *f (char * (*g) (char **, int), char **p, ...)
-{
- char *s;
- va_list v;
- va_start (v,p);
- s = g (p, va_arg (v,int));
- va_end (v);
- return s;
-}
-
-/* C89 style stringification. */
-#define noexpand_stringify(a) #a
-const char *stringified = noexpand_stringify(arbitrary+token=sequence);
-
-/* C89 style token pasting. Exercises some of the corner cases that
- e.g. old MSVC gets wrong, but not very hard. */
-#define noexpand_concat(a,b) a##b
-#define expand_concat(a,b) noexpand_concat(a,b)
-extern int vA;
-extern int vbee;
-#define aye A
-#define bee B
-int *pvA = &expand_concat(v,aye);
-int *pvbee = &noexpand_concat(v,bee);
-
-/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has
- function prototypes and stuff, but not \xHH hex character constants.
- These do not provoke an error unfortunately, instead are silently treated
- as an "x". The following induces an error, until -std is added to get
- proper ANSI mode. Curiously \x00 != x always comes out true, for an
- array size at least. It is necessary to write \x00 == 0 to get something
- that is true only with -std. */
-int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1];
-
-/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters
- inside strings and character constants. */
-#define FOO(x) '\''x'\''
-int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1];
-
-int test (int i, double x);
-struct s1 {int (*f) (int a);};
-struct s2 {int (*f) (double a);};
-int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int),
- int, int);'
-
-# Test code for whether the C compiler supports C89 (body of main).
-ac_c_conftest_c89_main='
-ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]);
-'
-
-# Test code for whether the C compiler supports C99 (global declarations)
-ac_c_conftest_c99_globals='
-/* Does the compiler advertise C99 conformance? */
-#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L
-# error "Compiler does not advertise C99 conformance"
-#endif
-
-// See if C++-style comments work.
-
-#include
-extern int puts (const char *);
-extern int printf (const char *, ...);
-extern int dprintf (int, const char *, ...);
-extern void *malloc (size_t);
-extern void free (void *);
-
-// Check varargs macros. These examples are taken from C99 6.10.3.5.
-// dprintf is used instead of fprintf to avoid needing to declare
-// FILE and stderr.
-#define debug(...) dprintf (2, __VA_ARGS__)
-#define showlist(...) puts (#__VA_ARGS__)
-#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__))
-static void
-test_varargs_macros (void)
-{
- int x = 1234;
- int y = 5678;
- debug ("Flag");
- debug ("X = %d\n", x);
- showlist (The first, second, and third items.);
- report (x>y, "x is %d but y is %d", x, y);
-}
-
-// Check long long types.
-#define BIG64 18446744073709551615ull
-#define BIG32 4294967295ul
-#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0)
-#if !BIG_OK
- #error "your preprocessor is broken"
-#endif
-#if BIG_OK
-#else
- #error "your preprocessor is broken"
-#endif
-static long long int bignum = -9223372036854775807LL;
-static unsigned long long int ubignum = BIG64;
-
-struct incomplete_array
-{
- int datasize;
- double data[];
-};
-
-struct named_init {
- int number;
- const wchar_t *name;
- double average;
-};
-
-typedef const char *ccp;
-
-static inline int
-test_restrict (ccp restrict text)
-{
- // Iterate through items via the restricted pointer.
- // Also check for declarations in for loops.
- for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i)
- continue;
- return 0;
-}
-
-// Check varargs and va_copy.
-static bool
-test_varargs (const char *format, ...)
-{
- va_list args;
- va_start (args, format);
- va_list args_copy;
- va_copy (args_copy, args);
-
- const char *str = "";
- int number = 0;
- float fnumber = 0;
-
- while (*format)
- {
- switch (*format++)
- {
- case '\''s'\'': // string
- str = va_arg (args_copy, const char *);
- break;
- case '\''d'\'': // int
- number = va_arg (args_copy, int);
- break;
- case '\''f'\'': // float
- fnumber = va_arg (args_copy, double);
- break;
- default:
- break;
- }
- }
- va_end (args_copy);
- va_end (args);
-
- return *str && number && fnumber;
-}
-'
-
-# Test code for whether the C compiler supports C99 (body of main).
-ac_c_conftest_c99_main='
- // Check bool.
- _Bool success = false;
- success |= (argc != 0);
-
- // Check restrict.
- if (test_restrict ("String literal") == 0)
- success = true;
- char *restrict newvar = "Another string";
-
- // Check varargs.
- success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234);
- test_varargs_macros ();
-
- // Check flexible array members.
- struct incomplete_array *ia =
- malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10));
- ia->datasize = 10;
- for (int i = 0; i < ia->datasize; ++i)
- ia->data[i] = i * 1.234;
- // Work around memory leak warnings.
- free (ia);
-
- // Check named initializers.
- struct named_init ni = {
- .number = 34,
- .name = L"Test wide string",
- .average = 543.34343,
- };
-
- ni.number = 58;
-
- int dynamic_array[ni.number];
- dynamic_array[0] = argv[0][0];
- dynamic_array[ni.number - 1] = 543;
-
- // work around unused variable warnings
- ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\''
- || dynamic_array[ni.number - 1] != 543);
-'
-
-# Test code for whether the C compiler supports C11 (global declarations)
-ac_c_conftest_c11_globals='
-/* Does the compiler advertise C11 conformance? */
-#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L
-# error "Compiler does not advertise C11 conformance"
-#endif
-
-// Check _Alignas.
-char _Alignas (double) aligned_as_double;
-char _Alignas (0) no_special_alignment;
-extern char aligned_as_int;
-char _Alignas (0) _Alignas (int) aligned_as_int;
-
-// Check _Alignof.
-enum
-{
- int_alignment = _Alignof (int),
- int_array_alignment = _Alignof (int[100]),
- char_alignment = _Alignof (char)
-};
-_Static_assert (0 < -_Alignof (int), "_Alignof is signed");
-
-// Check _Noreturn.
-int _Noreturn does_not_return (void) { for (;;) continue; }
-
-// Check _Static_assert.
-struct test_static_assert
-{
- int x;
- _Static_assert (sizeof (int) <= sizeof (long int),
- "_Static_assert does not work in struct");
- long int y;
-};
-
-// Check UTF-8 literals.
-#define u8 syntax error!
-char const utf8_literal[] = u8"happens to be ASCII" "another string";
-
-// Check duplicate typedefs.
-typedef long *long_ptr;
-typedef long int *long_ptr;
-typedef long_ptr long_ptr;
-
-// Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1.
-struct anonymous
-{
- union {
- struct { int i; int j; };
- struct { int k; long int l; } w;
- };
- int m;
-} v1;
-'
-
-# Test code for whether the C compiler supports C11 (body of main).
-ac_c_conftest_c11_main='
- _Static_assert ((offsetof (struct anonymous, i)
- == offsetof (struct anonymous, w.k)),
- "Anonymous union alignment botch");
- v1.i = 2;
- v1.w.k = 5;
- ok |= v1.i != 5;
-'
-
-# Test code for whether the C compiler supports C11 (complete).
-ac_c_conftest_c11_program="${ac_c_conftest_c89_globals}
-${ac_c_conftest_c99_globals}
-${ac_c_conftest_c11_globals}
-
-int
-main (int argc, char **argv)
-{
- int ok = 0;
- ${ac_c_conftest_c89_main}
- ${ac_c_conftest_c99_main}
- ${ac_c_conftest_c11_main}
- return ok;
-}
-"
-
-# Test code for whether the C compiler supports C99 (complete).
-ac_c_conftest_c99_program="${ac_c_conftest_c89_globals}
-${ac_c_conftest_c99_globals}
-
-int
-main (int argc, char **argv)
-{
- int ok = 0;
- ${ac_c_conftest_c89_main}
- ${ac_c_conftest_c99_main}
- return ok;
-}
-"
-
-# Test code for whether the C compiler supports C89 (complete).
-ac_c_conftest_c89_program="${ac_c_conftest_c89_globals}
-
-int
-main (int argc, char **argv)
-{
- int ok = 0;
- ${ac_c_conftest_c89_main}
- return ok;
-}
-"
-
-as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H"
-as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H"
-as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H"
-as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H"
-as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H"
-as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H"
-as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H"
-as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H"
-as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H"
-as_fn_append ac_header_c_list " sys/time.h sys_time_h HAVE_SYS_TIME_H"
-# Check that the precious variables saved in the cache have kept the same
-# value.
-ac_cache_corrupted=false
-for ac_var in $ac_precious_vars; do
- eval ac_old_set=\$ac_cv_env_${ac_var}_set
- eval ac_new_set=\$ac_env_${ac_var}_set
- eval ac_old_val=\$ac_cv_env_${ac_var}_value
- eval ac_new_val=\$ac_env_${ac_var}_value
- case $ac_old_set,$ac_new_set in
- set,)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5
-printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;}
- ac_cache_corrupted=: ;;
- ,set)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5
-printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;}
- ac_cache_corrupted=: ;;
- ,);;
- *)
- if test "x$ac_old_val" != "x$ac_new_val"; then
- # differences in whitespace do not lead to failure.
- ac_old_val_w=`echo x $ac_old_val`
- ac_new_val_w=`echo x $ac_new_val`
- if test "$ac_old_val_w" != "$ac_new_val_w"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5
-printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;}
- ac_cache_corrupted=:
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5
-printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;}
- eval $ac_var=\$ac_old_val
- fi
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5
-printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;}
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5
-printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;}
- fi;;
- esac
- # Pass precious variables to config.status.
- if test "$ac_new_set" = set; then
- case $ac_new_val in
- *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
- *) ac_arg=$ac_var=$ac_new_val ;;
- esac
- case " $ac_configure_args " in
- *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
- *) as_fn_append ac_configure_args " '$ac_arg'" ;;
- esac
- fi
-done
-if $ac_cache_corrupted; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5
-printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;}
- as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file'
- and start over" "$LINENO" 5
-fi
-## -------------------- ##
-## Main body of script. ##
-## -------------------- ##
-
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-
-
-
-
-TCL_VERSION=9.0
-TCL_MAJOR_VERSION=9
-TCL_MINOR_VERSION=0
-TCL_PATCH_LEVEL="b2"
-VERSION=${TCL_VERSION}
-
-EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
-EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}
-
-#------------------------------------------------------------------------
-# Setup configure arguments for bundled packages
-#------------------------------------------------------------------------
-
-PKG_CFG_ARGS="$ac_configure_args ${PKG_CFG_ARGS}"
-
-if test -r "$cache_file" -a -f "$cache_file"; then
- case $cache_file in
- [\\/]* | ?:[\\/]* ) pkg_cache_file=$cache_file ;;
- *) pkg_cache_file=../../$cache_file ;;
- esac
- PKG_CFG_ARGS="${PKG_CFG_ARGS} --cache-file=$pkg_cache_file"
-fi
-
-#------------------------------------------------------------------------
-# Empty slate for bundled packages, to avoid stale configuration
-#------------------------------------------------------------------------
-#rm -Rf pkgs
-if test -f Makefile; then
- make distclean-packages
-fi
-
-#------------------------------------------------------------------------
-# Handle the --prefix=... option
-#------------------------------------------------------------------------
-
-if test "${prefix}" = "NONE"; then
- prefix=/usr/local
-fi
-if test "${exec_prefix}" = "NONE"; then
- exec_prefix=$prefix
-fi
-# Make sure srcdir is fully qualified!
-srcdir="`cd "$srcdir" ; pwd`"
-TCL_SRC_DIR="`cd "$srcdir"/..; pwd`"
-
-#------------------------------------------------------------------------
-# Compress and/or soft link the manpages?
-#------------------------------------------------------------------------
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use symlinks for manpages" >&5
-printf %s "checking whether to use symlinks for manpages... " >&6; }
- # Check whether --enable-man-symlinks was given.
-if test ${enable_man_symlinks+y}
-then :
- enableval=$enable_man_symlinks; test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks"
-else case e in #(
- e) enableval="no" ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
-printf "%s\n" "$enableval" >&6; }
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to compress the manpages" >&5
-printf %s "checking whether to compress the manpages... " >&6; }
- # Check whether --enable-man-compression was given.
-if test ${enable_man_compression+y}
-then :
- enableval=$enable_man_compression; case $enableval in
- yes) as_fn_error $? "missing argument to --enable-man-compression" "$LINENO" 5;;
- no) ;;
- *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
- esac
-else case e in #(
- e) enableval="no" ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
-printf "%s\n" "$enableval" >&6; }
- if test "$enableval" != "no"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for compressed file suffix" >&5
-printf %s "checking for compressed file suffix... " >&6; }
- touch TeST
- $enableval TeST
- Z=`ls TeST* | sed 's/^....//'`
- rm -f TeST*
- MAN_FLAGS="$MAN_FLAGS --extension $Z"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $Z" >&5
-printf "%s\n" "$Z" >&6; }
- fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to add a package name suffix for the manpages" >&5
-printf %s "checking whether to add a package name suffix for the manpages... " >&6; }
- # Check whether --enable-man-suffix was given.
-if test ${enable_man_suffix+y}
-then :
- enableval=$enable_man_suffix; case $enableval in
- yes) enableval="tcl" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
- no) ;;
- *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
- esac
-else case e in #(
- e) enableval="no" ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $enableval" >&5
-printf "%s\n" "$enableval" >&6; }
-
-
-
-
-#------------------------------------------------------------------------
-# Standard compiler checks
-#------------------------------------------------------------------------
-
-# If the user did not set CFLAGS, set it now to keep
-# the AC_PROG_CC macro from adding "-g -O2".
-if test "${CFLAGS+set}" != "set" ; then
- CFLAGS=""
-fi
-
-
-
-
-
-
-
-
-
-
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.
-set dummy ${ac_tool_prefix}gcc; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_CC="${ac_tool_prefix}gcc"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-CC=$ac_cv_prog_CC
-if test -n "$CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
-printf "%s\n" "$CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
-fi
-if test -z "$ac_cv_prog_CC"; then
- ac_ct_CC=$CC
- # Extract the first word of "gcc", so it can be a program name with args.
-set dummy gcc; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_ac_ct_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$ac_ct_CC"; then
- ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_CC="gcc"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-ac_ct_CC=$ac_cv_prog_ac_ct_CC
-if test -n "$ac_ct_CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
-printf "%s\n" "$ac_ct_CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
- if test "x$ac_ct_CC" = x; then
- CC=""
- else
- case $cross_compiling:$ac_tool_warned in
-yes:)
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
-ac_tool_warned=yes ;;
-esac
- CC=$ac_ct_CC
- fi
-else
- CC="$ac_cv_prog_CC"
-fi
-
-if test -z "$CC"; then
- if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.
-set dummy ${ac_tool_prefix}cc; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_CC="${ac_tool_prefix}cc"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-CC=$ac_cv_prog_CC
-if test -n "$CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
-printf "%s\n" "$CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
- fi
-fi
-if test -z "$CC"; then
- # Extract the first word of "cc", so it can be a program name with args.
-set dummy cc; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
- ac_prog_rejected=no
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then
- ac_prog_rejected=yes
- continue
- fi
- ac_cv_prog_CC="cc"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-if test $ac_prog_rejected = yes; then
- # We found a bogon in the path, so make sure we never use it.
- set dummy $ac_cv_prog_CC
- shift
- if test $# != 0; then
- # We chose a different compiler from the bogus one.
- # However, it has the same basename, so the bogon will be chosen
- # first if we set CC to just the basename; use the full file name.
- shift
- ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@"
- fi
-fi
-fi ;;
-esac
-fi
-CC=$ac_cv_prog_CC
-if test -n "$CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
-printf "%s\n" "$CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
-fi
-if test -z "$CC"; then
- if test -n "$ac_tool_prefix"; then
- for ac_prog in cl.exe
- do
- # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.
-set dummy $ac_tool_prefix$ac_prog; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_CC="$ac_tool_prefix$ac_prog"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-CC=$ac_cv_prog_CC
-if test -n "$CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
-printf "%s\n" "$CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
- test -n "$CC" && break
- done
-fi
-if test -z "$CC"; then
- ac_ct_CC=$CC
- for ac_prog in cl.exe
-do
- # Extract the first word of "$ac_prog", so it can be a program name with args.
-set dummy $ac_prog; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_ac_ct_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$ac_ct_CC"; then
- ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_CC="$ac_prog"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-ac_ct_CC=$ac_cv_prog_ac_ct_CC
-if test -n "$ac_ct_CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
-printf "%s\n" "$ac_ct_CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
- test -n "$ac_ct_CC" && break
-done
-
- if test "x$ac_ct_CC" = x; then
- CC=""
- else
- case $cross_compiling:$ac_tool_warned in
-yes:)
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
-ac_tool_warned=yes ;;
-esac
- CC=$ac_ct_CC
- fi
-fi
-
-fi
-if test -z "$CC"; then
- if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args.
-set dummy ${ac_tool_prefix}clang; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_CC="${ac_tool_prefix}clang"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-CC=$ac_cv_prog_CC
-if test -n "$CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5
-printf "%s\n" "$CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
-fi
-if test -z "$ac_cv_prog_CC"; then
- ac_ct_CC=$CC
- # Extract the first word of "clang", so it can be a program name with args.
-set dummy clang; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_ac_ct_CC+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$ac_ct_CC"; then
- ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_CC="clang"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-ac_ct_CC=$ac_cv_prog_ac_ct_CC
-if test -n "$ac_ct_CC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5
-printf "%s\n" "$ac_ct_CC" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
- if test "x$ac_ct_CC" = x; then
- CC=""
- else
- case $cross_compiling:$ac_tool_warned in
-yes:)
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
-ac_tool_warned=yes ;;
-esac
- CC=$ac_ct_CC
- fi
-else
- CC="$ac_cv_prog_CC"
-fi
-
-fi
-
-
-test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "no acceptable C compiler found in \$PATH
-See 'config.log' for more details" "$LINENO" 5; }
-
-# Provide some information about the compiler.
-printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5
-set X $ac_compile
-ac_compiler=$2
-for ac_option in --version -v -V -qversion -version; do
- { { ac_try="$ac_compiler $ac_option >&5"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_compiler $ac_option >&5") 2>conftest.err
- ac_status=$?
- if test -s conftest.err; then
- sed '10a\
-... rest of stderr output deleted ...
- 10q' conftest.err >conftest.er1
- cat conftest.er1 >&5
- fi
- rm -f conftest.er1 conftest.err
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }
-done
-
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-ac_clean_files_save=$ac_clean_files
-ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"
-# Try to create an executable without -o first, disregard a.out.
-# It will help us diagnose broken compilers, and finding out an intuition
-# of exeext.
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5
-printf %s "checking whether the C compiler works... " >&6; }
-ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'`
-
-# The possible output files:
-ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"
-
-ac_rmfiles=
-for ac_file in $ac_files
-do
- case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
- * ) ac_rmfiles="$ac_rmfiles $ac_file";;
- esac
-done
-rm -f $ac_rmfiles
-
-if { { ac_try="$ac_link_default"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_link_default") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }
-then :
- # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'.
-# So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no'
-# in a Makefile. We should not override ac_cv_exeext if it was cached,
-# so that the user can short-circuit this test for compilers unknown to
-# Autoconf.
-for ac_file in $ac_files ''
-do
- test -f "$ac_file" || continue
- case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )
- ;;
- [ab].out )
- # We found the default executable, but exeext='' is most
- # certainly right.
- break;;
- *.* )
- if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no;
- then :; else
- ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- fi
- # We set ac_cv_exeext here because the later test for it is not
- # safe: cross compilers may not add the suffix if given an '-o'
- # argument, so we may need to know it at that point already.
- # Even if this section looks crufty: it has the advantage of
- # actually working.
- break;;
- * )
- break;;
- esac
-done
-test "$ac_cv_exeext" = no && ac_cv_exeext=
-
-else case e in #(
- e) ac_file='' ;;
-esac
-fi
-if test -z "$ac_file"
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error 77 "C compiler cannot create executables
-See 'config.log' for more details" "$LINENO" 5; }
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
-printf "%s\n" "yes" >&6; } ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5
-printf %s "checking for C compiler default output file name... " >&6; }
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5
-printf "%s\n" "$ac_file" >&6; }
-ac_exeext=$ac_cv_exeext
-
-rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out
-ac_clean_files=$ac_clean_files_save
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5
-printf %s "checking for suffix of executables... " >&6; }
-if { { ac_try="$ac_link"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_link") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }
-then :
- # If both 'conftest.exe' and 'conftest' are 'present' (well, observable)
-# catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will
-# work properly (i.e., refer to 'conftest.exe'), while it won't with
-# 'rm'.
-for ac_file in conftest.exe conftest conftest.*; do
- test -f "$ac_file" || continue
- case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;
- *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`
- break;;
- * ) break;;
- esac
-done
-else case e in #(
- e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "cannot compute suffix of executables: cannot compile and link
-See 'config.log' for more details" "$LINENO" 5; } ;;
-esac
-fi
-rm -f conftest conftest$ac_cv_exeext
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5
-printf "%s\n" "$ac_cv_exeext" >&6; }
-
-rm -f conftest.$ac_ext
-EXEEXT=$ac_cv_exeext
-ac_exeext=$EXEEXT
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-FILE *f = fopen ("conftest.out", "w");
- if (!f)
- return 1;
- return ferror (f) || fclose (f) != 0;
-
- ;
- return 0;
-}
-_ACEOF
-ac_clean_files="$ac_clean_files conftest.out"
-# Check that the compiler produces executables we can run. If not, either
-# the compiler is broken, or we cross compile.
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5
-printf %s "checking whether we are cross compiling... " >&6; }
-if test "$cross_compiling" != yes; then
- { { ac_try="$ac_link"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_link") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }
- if { ac_try='./conftest$ac_cv_exeext'
- { { case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_try") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }; }; then
- cross_compiling=no
- else
- if test "$cross_compiling" = maybe; then
- cross_compiling=yes
- else
- { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error 77 "cannot run C compiled programs.
-If you meant to cross compile, use '--host'.
-See 'config.log' for more details" "$LINENO" 5; }
- fi
- fi
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5
-printf "%s\n" "$cross_compiling" >&6; }
-
-rm -f conftest.$ac_ext conftest$ac_cv_exeext \
- conftest.o conftest.obj conftest.out
-ac_clean_files=$ac_clean_files_save
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5
-printf %s "checking for suffix of object files... " >&6; }
-if test ${ac_cv_objext+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-rm -f conftest.o conftest.obj
-if { { ac_try="$ac_compile"
-case "(($ac_try" in
- *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
- *) ac_try_echo=$ac_try;;
-esac
-eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""
-printf "%s\n" "$ac_try_echo"; } >&5
- (eval "$ac_compile") 2>&5
- ac_status=$?
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5
- test $ac_status = 0; }
-then :
- for ac_file in conftest.o conftest.obj conftest.*; do
- test -f "$ac_file" || continue;
- case $ac_file in
- *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;
- *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`
- break;;
- esac
-done
-else case e in #(
- e) printf "%s\n" "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "cannot compute suffix of object files: cannot compile
-See 'config.log' for more details" "$LINENO" 5; } ;;
-esac
-fi
-rm -f conftest.$ac_cv_objext conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5
-printf "%s\n" "$ac_cv_objext" >&6; }
-OBJEXT=$ac_cv_objext
-ac_objext=$OBJEXT
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5
-printf %s "checking whether the compiler supports GNU C... " >&6; }
-if test ${ac_cv_c_compiler_gnu+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-#ifndef __GNUC__
- choke me
-#endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_compiler_gnu=yes
-else case e in #(
- e) ac_compiler_gnu=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
-ac_cv_c_compiler_gnu=$ac_compiler_gnu
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5
-printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; }
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-if test $ac_compiler_gnu = yes; then
- GCC=yes
-else
- GCC=
-fi
-ac_test_CFLAGS=${CFLAGS+y}
-ac_save_CFLAGS=$CFLAGS
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5
-printf %s "checking whether $CC accepts -g... " >&6; }
-if test ${ac_cv_prog_cc_g+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_save_c_werror_flag=$ac_c_werror_flag
- ac_c_werror_flag=yes
- ac_cv_prog_cc_g=no
- CFLAGS="-g"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_prog_cc_g=yes
-else case e in #(
- e) CFLAGS=""
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
-
-else case e in #(
- e) ac_c_werror_flag=$ac_save_c_werror_flag
- CFLAGS="-g"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_prog_cc_g=yes
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- ac_c_werror_flag=$ac_save_c_werror_flag ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5
-printf "%s\n" "$ac_cv_prog_cc_g" >&6; }
-if test $ac_test_CFLAGS; then
- CFLAGS=$ac_save_CFLAGS
-elif test $ac_cv_prog_cc_g = yes; then
- if test "$GCC" = yes; then
- CFLAGS="-g -O2"
- else
- CFLAGS="-g"
- fi
-else
- if test "$GCC" = yes; then
- CFLAGS="-O2"
- else
- CFLAGS=
- fi
-fi
-ac_prog_cc_stdc=no
-if test x$ac_prog_cc_stdc = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5
-printf %s "checking for $CC option to enable C11 features... " >&6; }
-if test ${ac_cv_prog_cc_c11+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_cv_prog_cc_c11=no
-ac_save_CC=$CC
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$ac_c_conftest_c11_program
-_ACEOF
-for ac_arg in '' -std=gnu11
-do
- CC="$ac_save_CC $ac_arg"
- if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_prog_cc_c11=$ac_arg
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam
- test "x$ac_cv_prog_cc_c11" != "xno" && break
-done
-rm -f conftest.$ac_ext
-CC=$ac_save_CC ;;
-esac
-fi
-
-if test "x$ac_cv_prog_cc_c11" = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
-printf "%s\n" "unsupported" >&6; }
-else case e in #(
- e) if test "x$ac_cv_prog_cc_c11" = x
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
-printf "%s\n" "none needed" >&6; }
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5
-printf "%s\n" "$ac_cv_prog_cc_c11" >&6; }
- CC="$CC $ac_cv_prog_cc_c11" ;;
-esac
-fi
- ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11
- ac_prog_cc_stdc=c11 ;;
-esac
-fi
-fi
-if test x$ac_prog_cc_stdc = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5
-printf %s "checking for $CC option to enable C99 features... " >&6; }
-if test ${ac_cv_prog_cc_c99+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_cv_prog_cc_c99=no
-ac_save_CC=$CC
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$ac_c_conftest_c99_program
-_ACEOF
-for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99=
-do
- CC="$ac_save_CC $ac_arg"
- if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_prog_cc_c99=$ac_arg
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam
- test "x$ac_cv_prog_cc_c99" != "xno" && break
-done
-rm -f conftest.$ac_ext
-CC=$ac_save_CC ;;
-esac
-fi
-
-if test "x$ac_cv_prog_cc_c99" = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
-printf "%s\n" "unsupported" >&6; }
-else case e in #(
- e) if test "x$ac_cv_prog_cc_c99" = x
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
-printf "%s\n" "none needed" >&6; }
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5
-printf "%s\n" "$ac_cv_prog_cc_c99" >&6; }
- CC="$CC $ac_cv_prog_cc_c99" ;;
-esac
-fi
- ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99
- ac_prog_cc_stdc=c99 ;;
-esac
-fi
-fi
-if test x$ac_prog_cc_stdc = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5
-printf %s "checking for $CC option to enable C89 features... " >&6; }
-if test ${ac_cv_prog_cc_c89+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_cv_prog_cc_c89=no
-ac_save_CC=$CC
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$ac_c_conftest_c89_program
-_ACEOF
-for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"
-do
- CC="$ac_save_CC $ac_arg"
- if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_prog_cc_c89=$ac_arg
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam
- test "x$ac_cv_prog_cc_c89" != "xno" && break
-done
-rm -f conftest.$ac_ext
-CC=$ac_save_CC ;;
-esac
-fi
-
-if test "x$ac_cv_prog_cc_c89" = xno
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5
-printf "%s\n" "unsupported" >&6; }
-else case e in #(
- e) if test "x$ac_cv_prog_cc_c89" = x
-then :
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5
-printf "%s\n" "none needed" >&6; }
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5
-printf "%s\n" "$ac_cv_prog_cc_c89" >&6; }
- CC="$CC $ac_cv_prog_cc_c89" ;;
-esac
-fi
- ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89
- ac_prog_cc_stdc=c89 ;;
-esac
-fi
-fi
-
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inline" >&5
-printf %s "checking for inline... " >&6; }
-if test ${ac_cv_c_inline+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_cv_c_inline=no
-for ac_kw in inline __inline__ __inline; do
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#ifndef __cplusplus
-typedef int foo_t;
-static $ac_kw foo_t static_foo (void) {return 0; }
-$ac_kw foo_t foo (void) {return 0; }
-#endif
-
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_c_inline=$ac_kw
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- test "$ac_cv_c_inline" != no && break
-done
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5
-printf "%s\n" "$ac_cv_c_inline" >&6; }
-
-case $ac_cv_c_inline in
- inline | yes) ;;
- *)
- case $ac_cv_c_inline in
- no) ac_val=;;
- *) ac_val=$ac_cv_c_inline;;
- esac
- cat >>confdefs.h <<_ACEOF
-#ifndef __cplusplus
-#define inline $ac_val
-#endif
-_ACEOF
- ;;
-esac
-
-
-
-#--------------------------------------------------------------------
-# Supply substitutes for missing POSIX header files. Special notes:
-# - stdlib.h doesn't define strtol or strtoul in some versions
-# of SunOS
-# - some versions of string.h don't declare procedures such
-# as strstr
-# Do this early, otherwise an autoconf bug throws errors on configure
-#--------------------------------------------------------------------
-
-ac_header= ac_cache=
-for ac_item in $ac_header_c_list
-do
- if test $ac_cache; then
- ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default"
- if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then
- printf "%s\n" "#define $ac_item 1" >> confdefs.h
- fi
- ac_header= ac_cache=
- elif test $ac_header; then
- ac_cache=$ac_item
- else
- ac_header=$ac_item
- fi
-done
-
-
-
-
-
-
-
-
-if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes
-then :
-
-printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h
-
-fi
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5
-printf %s "checking how to run the C preprocessor... " >&6; }
-# On Suns, sometimes $CPP names a directory.
-if test -n "$CPP" && test -d "$CPP"; then
- CPP=
-fi
-if test -z "$CPP"; then
- if test ${ac_cv_prog_CPP+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) # Double quotes because $CC needs to be expanded
- for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp
- do
- ac_preproc_ok=false
-for ac_c_preproc_warn_flag in '' yes
-do
- # Use a header file that comes with gcc, so configuring glibc
- # with a fresh cross-compiler works.
- # On the NeXT, cc -E runs the code through the compiler's parser,
- # not just through cpp. "Syntax error" is here to catch this case.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
- Syntax error
-_ACEOF
-if ac_fn_c_try_cpp "$LINENO"
-then :
-
-else case e in #(
- e) # Broken: fails on valid input.
-continue ;;
-esac
-fi
-rm -f conftest.err conftest.i conftest.$ac_ext
-
- # OK, works on sane cases. Now check whether nonexistent headers
- # can be detected and how.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-_ACEOF
-if ac_fn_c_try_cpp "$LINENO"
-then :
- # Broken: success on invalid input.
-continue
-else case e in #(
- e) # Passes both tests.
-ac_preproc_ok=:
-break ;;
-esac
-fi
-rm -f conftest.err conftest.i conftest.$ac_ext
-
-done
-# Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.i conftest.err conftest.$ac_ext
-if $ac_preproc_ok
-then :
- break
-fi
-
- done
- ac_cv_prog_CPP=$CPP
- ;;
-esac
-fi
- CPP=$ac_cv_prog_CPP
-else
- ac_cv_prog_CPP=$CPP
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5
-printf "%s\n" "$CPP" >&6; }
-ac_preproc_ok=false
-for ac_c_preproc_warn_flag in '' yes
-do
- # Use a header file that comes with gcc, so configuring glibc
- # with a fresh cross-compiler works.
- # On the NeXT, cc -E runs the code through the compiler's parser,
- # not just through cpp. "Syntax error" is here to catch this case.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
- Syntax error
-_ACEOF
-if ac_fn_c_try_cpp "$LINENO"
-then :
-
-else case e in #(
- e) # Broken: fails on valid input.
-continue ;;
-esac
-fi
-rm -f conftest.err conftest.i conftest.$ac_ext
-
- # OK, works on sane cases. Now check whether nonexistent headers
- # can be detected and how.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-_ACEOF
-if ac_fn_c_try_cpp "$LINENO"
-then :
- # Broken: success on invalid input.
-continue
-else case e in #(
- e) # Passes both tests.
-ac_preproc_ok=:
-break ;;
-esac
-fi
-rm -f conftest.err conftest.i conftest.$ac_ext
-
-done
-# Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped.
-rm -f conftest.i conftest.err conftest.$ac_ext
-if $ac_preproc_ok
-then :
-
-else case e in #(
- e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "C preprocessor \"$CPP\" fails sanity check
-See 'config.log' for more details" "$LINENO" 5; } ;;
-esac
-fi
-
-ac_ext=c
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
-ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
-ac_compiler_gnu=$ac_cv_c_compiler_gnu
-
-
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep -e" >&5
-printf %s "checking for egrep -e... " >&6; }
-if test ${ac_cv_path_EGREP_TRADITIONAL+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -z "$EGREP_TRADITIONAL"; then
- ac_path_EGREP_TRADITIONAL_found=false
- # Loop through the user's path and test for each of PROGNAME-LIST
- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_prog in grep ggrep
- do
- for ac_exec_ext in '' $ac_executable_extensions; do
- ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext"
- as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue
-# Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found.
- # Check for GNU $ac_path_EGREP_TRADITIONAL
-case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #(
-*GNU*)
- ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;;
-#(
-*)
- ac_count=0
- printf %s 0123456789 >"conftest.in"
- while :
- do
- cat "conftest.in" "conftest.in" >"conftest.tmp"
- mv "conftest.tmp" "conftest.in"
- cp "conftest.in" "conftest.nl"
- printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl"
- "$ac_path_EGREP_TRADITIONAL" -E 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
- diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
- as_fn_arith $ac_count + 1 && ac_count=$as_val
- if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then
- # Best one so far, save it but keep looking for a better one
- ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL"
- ac_path_EGREP_TRADITIONAL_max=$ac_count
- fi
- # 10*(2^10) chars as input seems more than enough
- test $ac_count -gt 10 && break
- done
- rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
-esac
-
- $ac_path_EGREP_TRADITIONAL_found && break 3
- done
- done
- done
-IFS=$as_save_IFS
- if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then
- :
- fi
-else
- ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL
-fi
-
- if test "$ac_cv_path_EGREP_TRADITIONAL"
-then :
- ac_cv_path_EGREP_TRADITIONAL="$ac_cv_path_EGREP_TRADITIONAL -E"
-else case e in #(
- e) if test -z "$EGREP_TRADITIONAL"; then
- ac_path_EGREP_TRADITIONAL_found=false
- # Loop through the user's path and test for each of PROGNAME-LIST
- as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_prog in egrep
- do
- for ac_exec_ext in '' $ac_executable_extensions; do
- ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext"
- as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue
-# Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found.
- # Check for GNU $ac_path_EGREP_TRADITIONAL
-case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #(
-*GNU*)
- ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;;
-#(
-*)
- ac_count=0
- printf %s 0123456789 >"conftest.in"
- while :
- do
- cat "conftest.in" "conftest.in" >"conftest.tmp"
- mv "conftest.tmp" "conftest.in"
- cp "conftest.in" "conftest.nl"
- printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl"
- "$ac_path_EGREP_TRADITIONAL" 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break
- diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break
- as_fn_arith $ac_count + 1 && ac_count=$as_val
- if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then
- # Best one so far, save it but keep looking for a better one
- ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL"
- ac_path_EGREP_TRADITIONAL_max=$ac_count
- fi
- # 10*(2^10) chars as input seems more than enough
- test $ac_count -gt 10 && break
- done
- rm -f conftest.in conftest.tmp conftest.nl conftest.out;;
-esac
-
- $ac_path_EGREP_TRADITIONAL_found && break 3
- done
- done
- done
-IFS=$as_save_IFS
- if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then
- as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5
- fi
-else
- ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL
-fi
- ;;
-esac
-fi ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP_TRADITIONAL" >&5
-printf "%s\n" "$ac_cv_path_EGREP_TRADITIONAL" >&6; }
- EGREP_TRADITIONAL=$ac_cv_path_EGREP_TRADITIONAL
-
-
- ac_fn_c_check_header_compile "$LINENO" "string.h" "ac_cv_header_string_h" "$ac_includes_default"
-if test "x$ac_cv_header_string_h" = xyes
-then :
- tcl_ok=1
-else case e in #(
- e) tcl_ok=0 ;;
-esac
-fi
-
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP_TRADITIONAL "strstr" >/dev/null 2>&1
-then :
-
-else case e in #(
- e) tcl_ok=0 ;;
-esac
-fi
-rm -rf conftest*
-
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-
-_ACEOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- $EGREP_TRADITIONAL "strerror" >/dev/null 2>&1
-then :
-
-else case e in #(
- e) tcl_ok=0 ;;
-esac
-fi
-rm -rf conftest*
-
-
- # See also memmove check below for a place where NO_STRING_H can be
- # set and why.
-
- if test $tcl_ok = 0; then
-
-printf "%s\n" "#define NO_STRING_H 1" >>confdefs.h
-
- fi
-
- ac_fn_c_check_header_compile "$LINENO" "sys/wait.h" "ac_cv_header_sys_wait_h" "$ac_includes_default"
-if test "x$ac_cv_header_sys_wait_h" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_SYS_WAIT_H 1" >>confdefs.h
- ;;
-esac
-fi
-
- ac_fn_c_check_header_compile "$LINENO" "dlfcn.h" "ac_cv_header_dlfcn_h" "$ac_includes_default"
-if test "x$ac_cv_header_dlfcn_h" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_DLFCN_H 1" >>confdefs.h
- ;;
-esac
-fi
-
-
- # OS/390 lacks sys/param.h (and doesn't need it, by chance).
- ac_fn_c_check_header_compile "$LINENO" "sys/param.h" "ac_cv_header_sys_param_h" "$ac_includes_default"
-if test "x$ac_cv_header_sys_param_h" = xyes
-then :
- printf "%s\n" "#define HAVE_SYS_PARAM_H 1" >>confdefs.h
-
-fi
-
-
-
-#--------------------------------------------------------------------
-# Determines the correct executable file extension (.exe)
-#--------------------------------------------------------------------
-
-
-
-#------------------------------------------------------------------------
-# If we're using GCC, see if the compiler understands -pipe. If so, use it.
-# It makes compiling go faster. (This is only a performance feature.)
-#------------------------------------------------------------------------
-
-if test -z "$no_pipe" && test -n "$GCC"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -pipe" >&5
-printf %s "checking if the compiler understands -pipe... " >&6; }
-if test ${tcl_cv_cc_pipe+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_cc_pipe=yes
-else case e in #(
- e) tcl_cv_cc_pipe=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_pipe" >&5
-printf "%s\n" "$tcl_cv_cc_pipe" >&6; }
- if test $tcl_cv_cc_pipe = yes; then
- CFLAGS="$CFLAGS -pipe"
- fi
-fi
-
-#------------------------------------------------------------------------
-# Embedded configuration information, encoding to use for the values, TIP #59
-#------------------------------------------------------------------------
-
-
-
-# Check whether --with-encoding was given.
-if test ${with_encoding+y}
-then :
- withval=$with_encoding; with_tcencoding=${withval}
-fi
-
-
- if test x"${with_tcencoding}" != x ; then
-
-printf "%s\n" "#define TCL_CFGVAL_ENCODING \"${with_tcencoding}\"" >>confdefs.h
-
- else
-
-printf "%s\n" "#define TCL_CFGVAL_ENCODING \"utf-8\"" >>confdefs.h
-
- fi
-
-
-#--------------------------------------------------------------------
-# Look for libraries that we will need when compiling the Tcl shell
-#--------------------------------------------------------------------
-
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5
-printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; }
-if test ${ac_cv_c_undeclared_builtin_options+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_save_CFLAGS=$CFLAGS
- ac_cv_c_undeclared_builtin_options='cannot detect'
- for ac_arg in '' -fno-builtin; do
- CFLAGS="$ac_save_CFLAGS $ac_arg"
- # This test program should *not* compile successfully.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-(void) strchr;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
-
-else case e in #(
- e) # This test program should compile successfully.
- # No library function is consistently available on
- # freestanding implementations, so test against a dummy
- # declaration. Include always-available headers on the
- # off chance that they somehow elicit warnings.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-#include
-#include
-#include
-extern void ac_decl (int, char *);
-
-int
-main (void)
-{
-(void) ac_decl (0, (char *) 0);
- (void) ac_decl;
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- if test x"$ac_arg" = x
-then :
- ac_cv_c_undeclared_builtin_options='none needed'
-else case e in #(
- e) ac_cv_c_undeclared_builtin_options=$ac_arg ;;
-esac
-fi
- break
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- done
- CFLAGS=$ac_save_CFLAGS
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5
-printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; }
- case $ac_cv_c_undeclared_builtin_options in #(
- 'cannot detect') :
- { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5
-printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;}
-as_fn_error $? "cannot make $CC report undeclared builtins
-See 'config.log' for more details" "$LINENO" 5; } ;; #(
- 'none needed') :
- ac_c_undeclared_builtin_options='' ;; #(
- *) :
- ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;;
-esac
-
-
- #--------------------------------------------------------------------
- # On a few very rare systems, all of the libm.a stuff is
- # already in libc.a. Set compiler flags accordingly.
- #--------------------------------------------------------------------
-
- ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin"
-if test "x$ac_cv_func_sin" = xyes
-then :
- MATH_LIBS=""
-else case e in #(
- e) MATH_LIBS="-lm" ;;
-esac
-fi
-
-
- #--------------------------------------------------------------------
- # Interactive UNIX requires -linet instead of -lsocket, plus it
- # needs net/errno.h to define the socket-related error codes.
- #--------------------------------------------------------------------
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5
-printf %s "checking for main in -linet... " >&6; }
-if test ${ac_cv_lib_inet_main+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-linet $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-
-int
-main (void)
-{
-return main ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_inet_main=yes
-else case e in #(
- e) ac_cv_lib_inet_main=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_inet_main" >&5
-printf "%s\n" "$ac_cv_lib_inet_main" >&6; }
-if test "x$ac_cv_lib_inet_main" = xyes
-then :
- LIBS="$LIBS -linet"
-fi
-
- ac_fn_c_check_header_compile "$LINENO" "net/errno.h" "ac_cv_header_net_errno_h" "$ac_includes_default"
-if test "x$ac_cv_header_net_errno_h" = xyes
-then :
-
-
-printf "%s\n" "#define HAVE_NET_ERRNO_H 1" >>confdefs.h
-
-fi
-
-
- #--------------------------------------------------------------------
- # Check for the existence of the -lsocket and -lnsl libraries.
- # The order here is important, so that they end up in the right
- # order in the command line generated by make. Here are some
- # special considerations:
- # 1. Use "connect" and "accept" to check for -lsocket, and
- # "gethostbyname" to check for -lnsl.
- # 2. Use each function name only once: can't redo a check because
- # autoconf caches the results of the last check and won't redo it.
- # 3. Use -lnsl and -lsocket only if they supply procedures that
- # aren't already present in the normal libraries. This is because
- # IRIX 5.2 has libraries, but they aren't needed and they're
- # bogus: they goof up name resolution if used.
- # 4. On some SVR4 systems, can't use -lsocket without -lnsl too.
- # To get around this problem, check for both libraries together
- # if -lsocket doesn't work by itself.
- #--------------------------------------------------------------------
-
- tcl_checkBoth=0
- ac_fn_c_check_func "$LINENO" "connect" "ac_cv_func_connect"
-if test "x$ac_cv_func_connect" = xyes
-then :
- tcl_checkSocket=0
-else case e in #(
- e) tcl_checkSocket=1 ;;
-esac
-fi
-
- if test "$tcl_checkSocket" = 1; then
- ac_fn_c_check_func "$LINENO" "setsockopt" "ac_cv_func_setsockopt"
-if test "x$ac_cv_func_setsockopt" = xyes
-then :
-
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for setsockopt in -lsocket" >&5
-printf %s "checking for setsockopt in -lsocket... " >&6; }
-if test ${ac_cv_lib_socket_setsockopt+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lsocket $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char setsockopt (void);
-int
-main (void)
-{
-return setsockopt ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_socket_setsockopt=yes
-else case e in #(
- e) ac_cv_lib_socket_setsockopt=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_socket_setsockopt" >&5
-printf "%s\n" "$ac_cv_lib_socket_setsockopt" >&6; }
-if test "x$ac_cv_lib_socket_setsockopt" = xyes
-then :
- LIBS="$LIBS -lsocket"
-else case e in #(
- e) tcl_checkBoth=1 ;;
-esac
-fi
- ;;
-esac
-fi
-
- fi
- if test "$tcl_checkBoth" = 1; then
- tk_oldLibs=$LIBS
- LIBS="$LIBS -lsocket -lnsl"
- ac_fn_c_check_func "$LINENO" "accept" "ac_cv_func_accept"
-if test "x$ac_cv_func_accept" = xyes
-then :
- tcl_checkNsl=0
-else case e in #(
- e) LIBS=$tk_oldLibs ;;
-esac
-fi
-
- fi
- ac_fn_c_check_func "$LINENO" "gethostbyname" "ac_cv_func_gethostbyname"
-if test "x$ac_cv_func_gethostbyname" = xyes
-then :
-
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for gethostbyname in -lnsl" >&5
-printf %s "checking for gethostbyname in -lnsl... " >&6; }
-if test ${ac_cv_lib_nsl_gethostbyname+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lnsl $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char gethostbyname (void);
-int
-main (void)
-{
-return gethostbyname ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_nsl_gethostbyname=yes
-else case e in #(
- e) ac_cv_lib_nsl_gethostbyname=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_nsl_gethostbyname" >&5
-printf "%s\n" "$ac_cv_lib_nsl_gethostbyname" >&6; }
-if test "x$ac_cv_lib_nsl_gethostbyname" = xyes
-then :
- LIBS="$LIBS -lnsl"
-fi
- ;;
-esac
-fi
-
-
-
-printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-
-
-printf "%s\n" "#define _THREAD_SAFE 1" >>confdefs.h
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5
-printf %s "checking for pthread_mutex_init in -lpthread... " >&6; }
-if test ${ac_cv_lib_pthread_pthread_mutex_init+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthread $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char pthread_mutex_init (void);
-int
-main (void)
-{
-return pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_pthread_pthread_mutex_init=yes
-else case e in #(
- e) ac_cv_lib_pthread_pthread_mutex_init=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5
-printf "%s\n" "$ac_cv_lib_pthread_pthread_mutex_init" >&6; }
-if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = "no"; then
- # Check a little harder for __pthread_mutex_init in the same
- # library, as some systems hide it there until pthread.h is
- # defined. We could alternatively do an AC_TRY_COMPILE with
- # pthread.h, but that will work with libpthread really doesn't
- # exist, like AIX 4.2. [Bug: 4359]
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __pthread_mutex_init in -lpthread" >&5
-printf %s "checking for __pthread_mutex_init in -lpthread... " >&6; }
-if test ${ac_cv_lib_pthread___pthread_mutex_init+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthread $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char __pthread_mutex_init (void);
-int
-main (void)
-{
-return __pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_pthread___pthread_mutex_init=yes
-else case e in #(
- e) ac_cv_lib_pthread___pthread_mutex_init=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5
-printf "%s\n" "$ac_cv_lib_pthread___pthread_mutex_init" >&6; }
-if test "x$ac_cv_lib_pthread___pthread_mutex_init" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- fi
-
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthread"
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthreads" >&5
-printf %s "checking for pthread_mutex_init in -lpthreads... " >&6; }
-if test ${ac_cv_lib_pthreads_pthread_mutex_init+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lpthreads $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char pthread_mutex_init (void);
-int
-main (void)
-{
-return pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_pthreads_pthread_mutex_init=yes
-else case e in #(
- e) ac_cv_lib_pthreads_pthread_mutex_init=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5
-printf "%s\n" "$ac_cv_lib_pthreads_pthread_mutex_init" >&6; }
-if test "x$ac_cv_lib_pthreads_pthread_mutex_init" = xyes
-then :
- _ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -lpthreads"
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc" >&5
-printf %s "checking for pthread_mutex_init in -lc... " >&6; }
-if test ${ac_cv_lib_c_pthread_mutex_init+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lc $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char pthread_mutex_init (void);
-int
-main (void)
-{
-return pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_c_pthread_mutex_init=yes
-else case e in #(
- e) ac_cv_lib_c_pthread_mutex_init=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_pthread_mutex_init" >&5
-printf "%s\n" "$ac_cv_lib_c_pthread_mutex_init" >&6; }
-if test "x$ac_cv_lib_c_pthread_mutex_init" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = "no"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lc_r" >&5
-printf %s "checking for pthread_mutex_init in -lc_r... " >&6; }
-if test ${ac_cv_lib_c_r_pthread_mutex_init+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lc_r $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char pthread_mutex_init (void);
-int
-main (void)
-{
-return pthread_mutex_init ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_c_r_pthread_mutex_init=yes
-else case e in #(
- e) ac_cv_lib_c_r_pthread_mutex_init=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5
-printf "%s\n" "$ac_cv_lib_c_r_pthread_mutex_init" >&6; }
-if test "x$ac_cv_lib_c_r_pthread_mutex_init" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = "yes"; then
- # The space is needed
- THREADS_LIBS=" -pthread"
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&5
-printf "%s\n" "$as_me: WARNING: Don't know how to find pthread lib on your system - you must edit the LIBS in the Makefile..." >&2;}
- fi
- fi
- fi
- fi
-
- # Does the pthread-implementation provide
- # 'pthread_attr_setstacksize' ?
-
- ac_saved_libs=$LIBS
- LIBS="$LIBS $THREADS_LIBS"
- ac_fn_c_check_func "$LINENO" "pthread_attr_setstacksize" "ac_cv_func_pthread_attr_setstacksize"
-if test "x$ac_cv_func_pthread_attr_setstacksize" = xyes
-then :
- printf "%s\n" "#define HAVE_PTHREAD_ATTR_SETSTACKSIZE 1" >>confdefs.h
-
-fi
-ac_fn_c_check_func "$LINENO" "pthread_atfork" "ac_cv_func_pthread_atfork"
-if test "x$ac_cv_func_pthread_atfork" = xyes
-then :
- printf "%s\n" "#define HAVE_PTHREAD_ATFORK 1" >>confdefs.h
-
-fi
-
- LIBS=$ac_saved_libs
-
- # TIP #509
- ac_fn_check_decl "$LINENO" "PTHREAD_MUTEX_RECURSIVE" "ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" "#include
-" "$ac_c_undeclared_builtin_options" "CFLAGS"
-if test "x$ac_cv_have_decl_PTHREAD_MUTEX_RECURSIVE" = xyes
-then :
- ac_have_decl=1
-else case e in #(
- e) ac_have_decl=0 ;;
-esac
-fi
-printf "%s\n" "#define HAVE_DECL_PTHREAD_MUTEX_RECURSIVE $ac_have_decl" >>confdefs.h
-if test $ac_have_decl = 1
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
-
-
-# Add the threads support libraries
-LIBS="$LIBS$THREADS_LIBS"
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5
-printf %s "checking how to build libraries... " >&6; }
- # Check whether --enable-shared was given.
-if test ${enable_shared+y}
-then :
- enableval=$enable_shared; tcl_ok=$enableval
-else case e in #(
- e) tcl_ok=yes ;;
-esac
-fi
-
- if test "$tcl_ok" = "yes" ; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: shared" >&5
-printf "%s\n" "shared" >&6; }
- SHARED_BUILD=1
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: static" >&5
-printf "%s\n" "static" >&6; }
- SHARED_BUILD=0
-
-printf "%s\n" "#define STATIC_BUILD 1" >>confdefs.h
-
- fi
-
-
-
-#--------------------------------------------------------------------
-# Look for a native installed tclsh binary (if available)
-# If one cannot be found then use the binary we build (fails for
-# cross compiling). This is used for NATIVE_TCLSH in Makefile.
-#--------------------------------------------------------------------
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for tclsh" >&5
-printf %s "checking for tclsh... " >&6; }
- if test ${ac_cv_path_tclsh+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- search_path=`echo ${PATH} | sed -e 's/:/ /g'`
- for dir in $search_path ; do
- for j in `ls -r $dir/tclsh[8-9]* 2> /dev/null` \
- `ls -r $dir/tclsh* 2> /dev/null` ; do
- if test x"$ac_cv_path_tclsh" = x ; then
- if test -f "$j" ; then
- ac_cv_path_tclsh=$j
- break
- fi
- fi
- done
- done
- ;;
-esac
-fi
-
-
- if test -f "$ac_cv_path_tclsh" ; then
- TCLSH_PROG="$ac_cv_path_tclsh"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $TCLSH_PROG" >&5
-printf "%s\n" "$TCLSH_PROG" >&6; }
- else
- # It is not an error if an installed version of Tcl can't be located.
- TCLSH_PROG=""
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: No tclsh found on PATH" >&5
-printf "%s\n" "No tclsh found on PATH" >&6; }
- fi
-
-
-if test "$TCLSH_PROG" = ""; then
- TCLSH_PROG='./${TCL_EXE}'
-fi
-
-#------------------------------------------------------------------------
-# Add stuff for zlib
-#------------------------------------------------------------------------
-
-zlib_ok=yes
-ac_fn_c_check_header_compile "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default"
-if test "x$ac_cv_header_zlib_h" = xyes
-then :
-
- ac_fn_c_check_type "$LINENO" "gz_header" "ac_cv_type_gz_header" "#include
-"
-if test "x$ac_cv_type_gz_header" = xyes
-then :
-
-else case e in #(
- e) zlib_ok=no ;;
-esac
-fi
-
-else case e in #(
- e)
- zlib_ok=no ;;
-esac
-fi
-
-if test $zlib_ok = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing deflateSetHeader" >&5
-printf %s "checking for library containing deflateSetHeader... " >&6; }
-if test ${ac_cv_search_deflateSetHeader+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_func_search_save_LIBS=$LIBS
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char deflateSetHeader (void);
-int
-main (void)
-{
-return deflateSetHeader ();
- ;
- return 0;
-}
-_ACEOF
-for ac_lib in '' z
-do
- if test -z "$ac_lib"; then
- ac_res="none required"
- else
- ac_res=-l$ac_lib
- LIBS="-l$ac_lib $ac_func_search_save_LIBS"
- fi
- if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_search_deflateSetHeader=$ac_res
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext
- if test ${ac_cv_search_deflateSetHeader+y}
-then :
- break
-fi
-done
-if test ${ac_cv_search_deflateSetHeader+y}
-then :
-
-else case e in #(
- e) ac_cv_search_deflateSetHeader=no ;;
-esac
-fi
-rm conftest.$ac_ext
-LIBS=$ac_func_search_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_deflateSetHeader" >&5
-printf "%s\n" "$ac_cv_search_deflateSetHeader" >&6; }
-ac_res=$ac_cv_search_deflateSetHeader
-if test "$ac_res" != no
-then :
- test "$ac_res" = "none required" || LIBS="$ac_res $LIBS"
-
-else case e in #(
- e)
- zlib_ok=no
- ;;
-esac
-fi
-
-fi
-if test $zlib_ok = no
-then :
-
- ZLIB_OBJS=\${ZLIB_OBJS}
-
- ZLIB_SRCS=\${ZLIB_SRCS}
-
- ZLIB_INCLUDE=-I\${ZLIB_DIR}
-
-
-fi
-
-printf "%s\n" "#define HAVE_ZLIB 1" >>confdefs.h
-
-
-#------------------------------------------------------------------------
-# Add stuff for libtommath
-
-libtommath_ok=yes
-
-# Check whether --with-system-libtommath was given.
-if test ${with_system_libtommath+y}
-then :
- withval=$with_system_libtommath; libtommath_ok=${withval}
-fi
-
-if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
- ac_fn_c_check_header_compile "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default"
-if test "x$ac_cv_header_tommath_h" = xyes
-then :
-
- ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include
-"
-if test "x$ac_cv_type_mp_int" = xyes
-then :
-
-else case e in #(
- e) libtommath_ok=no ;;
-esac
-fi
-
-else case e in #(
- e)
- libtommath_ok=no ;;
-esac
-fi
-
- if test $libtommath_ok = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5
-printf %s "checking for mp_log_u32 in -ltommath... " >&6; }
-if test ${ac_cv_lib_tommath_mp_log_u32+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-ltommath $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char mp_log_u32 (void);
-int
-main (void)
-{
-return mp_log_u32 ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_tommath_mp_log_u32=yes
-else case e in #(
- e) ac_cv_lib_tommath_mp_log_u32=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5
-printf "%s\n" "$ac_cv_lib_tommath_mp_log_u32" >&6; }
-if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes
-then :
- MATH_LIBS="$MATH_LIBS -ltommath"
-else case e in #(
- e)
- libtommath_ok=no ;;
-esac
-fi
-
-fi
-fi
-if test $libtommath_ok = yes
-then :
-
- TCL_PC_REQUIRES_PRIVATE='libtommath >= 1.2.0,'
-
- TCL_PC_CFLAGS='-DTCL_WITH_EXTERNAL_TOMMATH'
-
-
-printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
-
-
-else case e in #(
- e)
- TOMMATH_OBJS=\${TOMMATH_OBJS}
-
- TOMMATH_SRCS=\${TOMMATH_SRCS}
-
- TOMMATH_INCLUDE=-I\${TOMMATH_DIR}
-
- ;;
-esac
-fi
-
-#--------------------------------------------------------------------
-# The statements below define a collection of compile flags. This
-# macro depends on the value of SHARED_BUILD, and should be called
-# after SC_ENABLE_SHARED checks the configure switches.
-#--------------------------------------------------------------------
-
-if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
-set dummy ${ac_tool_prefix}ranlib; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_RANLIB+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$RANLIB"; then
- ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-RANLIB=$ac_cv_prog_RANLIB
-if test -n "$RANLIB"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5
-printf "%s\n" "$RANLIB" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
-fi
-if test -z "$ac_cv_prog_RANLIB"; then
- ac_ct_RANLIB=$RANLIB
- # Extract the first word of "ranlib", so it can be a program name with args.
-set dummy ranlib; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_ac_ct_RANLIB+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$ac_ct_RANLIB"; then
- ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_RANLIB="ranlib"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB
-if test -n "$ac_ct_RANLIB"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5
-printf "%s\n" "$ac_ct_RANLIB" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
- if test "x$ac_ct_RANLIB" = x; then
- RANLIB=":"
- else
- case $cross_compiling:$ac_tool_warned in
-yes:)
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
-ac_tool_warned=yes ;;
-esac
- RANLIB=$ac_ct_RANLIB
- fi
-else
- RANLIB="$ac_cv_prog_RANLIB"
-fi
-
-
-
- # Step 0.a: Enable 64 bit support?
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5
-printf %s "checking if 64bit support is requested... " >&6; }
- # Check whether --enable-64bit was given.
-if test ${enable_64bit+y}
-then :
- enableval=$enable_64bit; do64bit=$enableval
-else case e in #(
- e) do64bit=no ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5
-printf "%s\n" "$do64bit" >&6; }
-
- # Step 0.b: Enable Solaris 64 bit VIS support?
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 64bit Sparc VIS support is requested" >&5
-printf %s "checking if 64bit Sparc VIS support is requested... " >&6; }
- # Check whether --enable-64bit-vis was given.
-if test ${enable_64bit_vis+y}
-then :
- enableval=$enable_64bit_vis; do64bitVIS=$enableval
-else case e in #(
- e) do64bitVIS=no ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $do64bitVIS" >&5
-printf "%s\n" "$do64bitVIS" >&6; }
- # Force 64bit on with VIS
- if test "$do64bitVIS" = "yes"
-then :
- do64bit=yes
-fi
-
- # Step 0.c: Check if visibility support is available. Do this here so
- # that platform specific alternatives can be used below if this fails.
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler supports visibility \"hidden\"" >&5
-printf %s "checking if compiler supports visibility \"hidden\"... " >&6; }
-if test ${tcl_cv_cc_visibility_hidden+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- extern __attribute__((__visibility__("hidden"))) void f(void);
- void f(void) {}
-int
-main (void)
-{
-f();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_cc_visibility_hidden=yes
-else case e in #(
- e) tcl_cv_cc_visibility_hidden=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_visibility_hidden" >&5
-printf "%s\n" "$tcl_cv_cc_visibility_hidden" >&6; }
- if test $tcl_cv_cc_visibility_hidden = yes
-then :
-
-
-printf "%s\n" "#define MODULE_SCOPE extern __attribute__((__visibility__(\"hidden\")))" >>confdefs.h
-
-
-printf "%s\n" "#define HAVE_HIDDEN 1" >>confdefs.h
-
-
-fi
-
- # Step 0.d: Disable -rpath support?
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if rpath support is requested" >&5
-printf %s "checking if rpath support is requested... " >&6; }
- # Check whether --enable-rpath was given.
-if test ${enable_rpath+y}
-then :
- enableval=$enable_rpath; doRpath=$enableval
-else case e in #(
- e) doRpath=yes ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $doRpath" >&5
-printf "%s\n" "$doRpath" >&6; }
-
- # Step 1: set the variable "system" to hold the name and version number
- # for the system.
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking system version" >&5
-printf %s "checking system version... " >&6; }
-if test ${tcl_cv_sys_version+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- if test "${TEA_PLATFORM}" = "windows" ; then
- tcl_cv_sys_version=windows
- else
- tcl_cv_sys_version=`uname -s`-`uname -r`
- if test "$?" -ne 0 ; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
-printf "%s\n" "$as_me: WARNING: can't find uname command" >&2;}
- tcl_cv_sys_version=unknown
- else
- if test "`uname -s`" = "AIX" ; then
- tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
- fi
- if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
- tcl_cv_sys_version=NetBSD-Debian
- fi
- fi
- fi
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
-printf "%s\n" "$tcl_cv_sys_version" >&6; }
- system=$tcl_cv_sys_version
-
-
- # Step 2: check for existence of -ldl library. This is needed because
- # Linux can use either -ldl or -ldld for dynamic loading.
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5
-printf %s "checking for dlopen in -ldl... " >&6; }
-if test ${ac_cv_lib_dl_dlopen+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-ldl $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char dlopen (void);
-int
-main (void)
-{
-return dlopen ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_dl_dlopen=yes
-else case e in #(
- e) ac_cv_lib_dl_dlopen=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5
-printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; }
-if test "x$ac_cv_lib_dl_dlopen" = xyes
-then :
- have_dl=yes
-else case e in #(
- e) have_dl=no ;;
-esac
-fi
-
-
- # Require ranlib early so we can override it in special cases below.
-
-
-
- # Step 3: set configuration options based on system name and version.
-
- do64bit_ok=no
- # default to '{$LIBS}' and set to "" on per-platform necessary basis
- SHLIB_LD_LIBS='${LIBS}'
- LDFLAGS_ORIG="$LDFLAGS"
- # When ld needs options to work in 64-bit mode, put them in
- # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load]
- # is disabled by the user. [Bug 1016796]
- LDFLAGS_ARCH=""
- UNSHARED_LIB_SUFFIX=""
- TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
- ECHO_VERSION='`echo ${VERSION}`'
- TCL_LIB_VERSIONS_OK=ok
- CFLAGS_DEBUG=-g
- if test "$GCC" = yes
-then :
-
- CFLAGS_OPTIMIZE=-O2
- CFLAGS_WARNING="-Wall -Wextra -Wshadow -Wundef -Wwrite-strings -Wpointer-arith"
- case "${CC}" in
- *++|*++-*)
- ;;
- *)
- CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -fextended-identifiers"
- ;;
- esac
-
-
-else case e in #(
- e)
- CFLAGS_OPTIMIZE=-O
- CFLAGS_WARNING=""
- ;;
-esac
-fi
- if test -n "$ac_tool_prefix"; then
- # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
-set dummy ${ac_tool_prefix}ar; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_AR+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$AR"; then
- ac_cv_prog_AR="$AR" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_AR="${ac_tool_prefix}ar"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-AR=$ac_cv_prog_AR
-if test -n "$AR"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $AR" >&5
-printf "%s\n" "$AR" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
-
-fi
-if test -z "$ac_cv_prog_AR"; then
- ac_ct_AR=$AR
- # Extract the first word of "ar", so it can be a program name with args.
-set dummy ar; ac_word=$2
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
-printf %s "checking for $ac_word... " >&6; }
-if test ${ac_cv_prog_ac_ct_AR+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) if test -n "$ac_ct_AR"; then
- ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test.
-else
-as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
-for as_dir in $PATH
-do
- IFS=$as_save_IFS
- case $as_dir in #(((
- '') as_dir=./ ;;
- */) ;;
- *) as_dir=$as_dir/ ;;
- esac
- for ac_exec_ext in '' $ac_executable_extensions; do
- if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
- ac_cv_prog_ac_ct_AR="ar"
- printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
- break 2
- fi
-done
- done
-IFS=$as_save_IFS
-
-fi ;;
-esac
-fi
-ac_ct_AR=$ac_cv_prog_ac_ct_AR
-if test -n "$ac_ct_AR"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5
-printf "%s\n" "$ac_ct_AR" >&6; }
-else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-fi
-
- if test "x$ac_ct_AR" = x; then
- AR=""
- else
- case $cross_compiling:$ac_tool_warned in
-yes:)
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
-printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
-ac_tool_warned=yes ;;
-esac
- AR=$ac_ct_AR
- fi
-else
- AR="$ac_cv_prog_AR"
-fi
-
- STLIB_LD='${AR} cr'
- LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
- PLAT_OBJS=""
- PLAT_SRCS=""
- LDAIX_SRC=""
- if test "x${SHLIB_VERSION}" = x
-then :
- SHLIB_VERSION="1.0"
-fi
- case $system in
- AIX-*)
- if test "$GCC" != "yes"
-then :
-
- # AIX requires the _r compiler when gcc isn't being used
- case "${CC}" in
- *_r|*_r\ *)
- # ok ...
- ;;
- *)
- # Make sure only first arg gets _r
- CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'`
- ;;
- esac
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: Using $CC for compiling with threads" >&5
-printf "%s\n" "Using $CC for compiling with threads" >&6; }
-
-fi
- LIBS="$LIBS -lc"
- SHLIB_CFLAGS=""
- SHLIB_SUFFIX=".so"
-
- DL_OBJS="tclLoadDl.o"
- LD_LIBRARY_PATH_VAR="LIBPATH"
-
- # ldAix No longer needed with use of -bexpall/-brtl
- # but some extensions may still reference it
- LDAIX_SRC='$(UNIX_DIR)/ldAix'
-
- # Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = yes
-then :
-
- if test "$GCC" = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
-
-else case e in #(
- e)
- do64bit_ok=yes
- CFLAGS="$CFLAGS -q64"
- LDFLAGS_ARCH="-q64"
- RANLIB="${RANLIB} -X64"
- AR="${AR} -X64"
- SHLIB_LD_FLAGS="-b64"
- ;;
-esac
-fi
-
-fi
-
- if test "`uname -m`" = ia64
-then :
-
- # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
- # AIX-5 has dl* in libc.so
- DL_LIBS=""
- if test "$GCC" = yes
-then :
-
- CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
-
-else case e in #(
- e)
- CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
- ;;
-esac
-fi
- LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
-
-else case e in #(
- e)
- if test "$GCC" = yes
-then :
-
- SHLIB_LD='${CC} -shared -Wl,-bexpall'
-
-else case e in #(
- e)
- SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry"
- LDFLAGS="$LDFLAGS -brtl"
- ;;
-esac
-fi
- SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- ;;
-esac
-fi
- ;;
- BeOS*)
- SHLIB_CFLAGS="-fPIC"
- SHLIB_LD='${CC} -nostart'
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
-
- #-----------------------------------------------------------
- # Check for inet_ntoa in -lbind, for BeOS (which also needs
- # -lsocket, even if the network functions are in -lnet which
- # is always linked to, for compatibility.
- #-----------------------------------------------------------
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lbind" >&5
-printf %s "checking for inet_ntoa in -lbind... " >&6; }
-if test ${ac_cv_lib_bind_inet_ntoa+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lbind $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char inet_ntoa (void);
-int
-main (void)
-{
-return inet_ntoa ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_bind_inet_ntoa=yes
-else case e in #(
- e) ac_cv_lib_bind_inet_ntoa=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bind_inet_ntoa" >&5
-printf "%s\n" "$ac_cv_lib_bind_inet_ntoa" >&6; }
-if test "x$ac_cv_lib_bind_inet_ntoa" = xyes
-then :
- LIBS="$LIBS -lbind -lsocket"
-fi
-
- ;;
- BSD/OS-2.1*|BSD/OS-3*)
- SHLIB_CFLAGS=""
- SHLIB_LD="shlicc -r"
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- BSD/OS-4.*)
- SHLIB_CFLAGS="-export-dynamic -fPIC"
- SHLIB_LD='${CC} -shared'
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- LDFLAGS="$LDFLAGS -export-dynamic"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- CYGWIN_*|MINGW32_*|MSYS_*)
- SHLIB_CFLAGS="-fno-common"
- SHLIB_LD='${CC} -shared'
- SHLIB_SUFFIX=".dll"
- DL_OBJS="tclLoadDl.o"
- PLAT_OBJS='${CYGWIN_OBJS}'
- PLAT_SRCS='${CYGWIN_SRCS}'
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5
-printf %s "checking for Cygwin version of gcc... " >&6; }
-if test ${ac_cv_cygwin+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #ifdef __CYGWIN__
- #error cygwin
- #endif
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_cygwin=no
-else case e in #(
- e) ac_cv_cygwin=yes ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cygwin" >&5
-printf "%s\n" "$ac_cv_cygwin" >&6; }
- if test "$ac_cv_cygwin" = "no"; then
- as_fn_error $? "${CC} is not a cygwin compiler." "$LINENO" 5
- fi
- do64bit_ok=yes
- if test "x${SHARED_BUILD}" = "x1"; then
- echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32"
- # The eval makes quoting arguments work.
- if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32; cd ../unix
- then :
- else
- { echo "configure: error: configure failed for ../win" 1>&2; exit 1; }
- fi
- fi
- ;;
- dgux*)
- SHLIB_CFLAGS="-K PIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- Haiku*)
- LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
- SHLIB_CFLAGS="-fPIC"
- SHLIB_SUFFIX=".so"
- SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-lroot"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for inet_ntoa in -lnetwork" >&5
-printf %s "checking for inet_ntoa in -lnetwork... " >&6; }
-if test ${ac_cv_lib_network_inet_ntoa+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-lnetwork $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char inet_ntoa (void);
-int
-main (void)
-{
-return inet_ntoa ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_network_inet_ntoa=yes
-else case e in #(
- e) ac_cv_lib_network_inet_ntoa=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_network_inet_ntoa" >&5
-printf "%s\n" "$ac_cv_lib_network_inet_ntoa" >&6; }
-if test "x$ac_cv_lib_network_inet_ntoa" = xyes
-then :
- LIBS="$LIBS -lnetwork"
-fi
-
- ;;
- HP-UX-*.11.*)
- # Use updated header definitions where possible
-
-printf "%s\n" "#define _XOPEN_SOURCE_EXTENDED 1" >>confdefs.h
-
-
-printf "%s\n" "#define _XOPEN_SOURCE 1" >>confdefs.h
-
- LIBS="$LIBS -lxnet" # Use the XOPEN network library
-
- if test "`uname -m`" = ia64
-then :
-
- SHLIB_SUFFIX=".so"
-
-else case e in #(
- e)
- SHLIB_SUFFIX=".sl"
- ;;
-esac
-fi
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
-printf %s "checking for shl_load in -ldld... " >&6; }
-if test ${ac_cv_lib_dld_shl_load+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-ldld $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char shl_load (void);
-int
-main (void)
-{
-return shl_load ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_dld_shl_load=yes
-else case e in #(
- e) ac_cv_lib_dld_shl_load=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
-printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
-if test "x$ac_cv_lib_dld_shl_load" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = yes
-then :
-
- SHLIB_CFLAGS="+z"
- SHLIB_LD="ld -b"
- DL_OBJS="tclLoadShl.o"
- DL_LIBS="-ldld"
- LDFLAGS="$LDFLAGS -Wl,-E"
- CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
- LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
- LD_LIBRARY_PATH_VAR="SHLIB_PATH"
-
-fi
- if test "$GCC" = yes
-then :
-
- SHLIB_LD='${CC} -shared'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-
-else case e in #(
- e)
- CFLAGS="$CFLAGS -z"
- ;;
-esac
-fi
-
- # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
- #CFLAGS="$CFLAGS +DAportable"
-
- # Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = "yes"
-then :
-
- if test "$GCC" = yes
-then :
-
- case `${CC} -dumpmachine` in
- hppa64*)
- # 64-bit gcc in use. Fix flags for GNU ld.
- do64bit_ok=yes
- SHLIB_LD='${CC} -shared'
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
-fi
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- ;;
- *)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
- ;;
- esac
-
-else case e in #(
- e)
- do64bit_ok=yes
- CFLAGS="$CFLAGS +DD64"
- LDFLAGS_ARCH="+DD64"
- ;;
-esac
-fi
-
-fi ;;
- HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
- SHLIB_SUFFIX=".sl"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5
-printf %s "checking for shl_load in -ldld... " >&6; }
-if test ${ac_cv_lib_dld_shl_load+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_check_lib_save_LIBS=$LIBS
-LIBS="-ldld $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-/* Override any GCC internal prototype to avoid an error.
- Use char because int might match the return type of a GCC
- builtin and then its argument prototype would still apply.
- The 'extern "C"' is for builds by C++ compilers;
- although this is not generally supported in C code supporting it here
- has little cost and some practical benefit (sr 110532). */
-#ifdef __cplusplus
-extern "C"
-#endif
-char shl_load (void);
-int
-main (void)
-{
-return shl_load ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- ac_cv_lib_dld_shl_load=yes
-else case e in #(
- e) ac_cv_lib_dld_shl_load=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5
-printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; }
-if test "x$ac_cv_lib_dld_shl_load" = xyes
-then :
- tcl_ok=yes
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
- if test "$tcl_ok" = yes
-then :
-
- SHLIB_CFLAGS="+z"
- SHLIB_LD="ld -b"
- SHLIB_LD_LIBS=""
- DL_OBJS="tclLoadShl.o"
- DL_LIBS="-ldld"
- LDFLAGS="$LDFLAGS -Wl,-E"
- CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
- LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
- LD_LIBRARY_PATH_VAR="SHLIB_PATH"
-
-fi ;;
- IRIX-5.*)
- SHLIB_CFLAGS=""
- SHLIB_LD="ld -shared -rdata_shared"
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- case " $LIBOBJS " in
- *" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
- ;;
-esac
-
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
- LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
-fi
- ;;
- IRIX-6.*)
- SHLIB_CFLAGS=""
- SHLIB_LD="ld -n32 -shared -rdata_shared"
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- case " $LIBOBJS " in
- *" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
- ;;
-esac
-
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
- LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
-fi
- if test "$GCC" = yes
-then :
-
- CFLAGS="$CFLAGS -mabi=n32"
- LDFLAGS="$LDFLAGS -mabi=n32"
-
-else case e in #(
- e)
- case $system in
- IRIX-6.3)
- # Use to build 6.2 compatible binaries on 6.3.
- CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS"
- ;;
- *)
- CFLAGS="$CFLAGS -n32"
- ;;
- esac
- LDFLAGS="$LDFLAGS -n32"
- ;;
-esac
-fi
- ;;
- IRIX64-6.*)
- SHLIB_CFLAGS=""
- SHLIB_LD="ld -n32 -shared -rdata_shared"
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- case " $LIBOBJS " in
- *" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
- ;;
-esac
-
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
- LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
-fi
-
- # Check to enable 64-bit flags for compiler/linker
-
- if test "$do64bit" = yes
-then :
-
- if test "$GCC" = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported by gcc" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported by gcc" >&2;}
-
-else case e in #(
- e)
- do64bit_ok=yes
- SHLIB_LD="ld -64 -shared -rdata_shared"
- CFLAGS="$CFLAGS -64"
- LDFLAGS_ARCH="-64"
- ;;
-esac
-fi
-
-fi
- ;;
- Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*)
- SHLIB_CFLAGS="-fPIC -fno-common"
- SHLIB_SUFFIX=".so"
-
- CFLAGS_OPTIMIZE="-O2"
- # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
- # when you inline the string and math operations. Turn this off to
- # get rid of the warnings.
- #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
-
- SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
-
- case $system in
- DragonFly-*|FreeBSD-*)
- # The -pthread needs to go in the LDFLAGS, not LIBS
- LIBS=`echo $LIBS | sed s/-pthread//`
- CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
- LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
- ;;
- esac
-
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
-fi
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- if test "`uname -m`" = "alpha"
-then :
- CFLAGS="$CFLAGS -mieee"
-fi
- if test $do64bit = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -m64 flag" >&5
-printf %s "checking if compiler accepts -m64 flag... " >&6; }
-if test ${tcl_cv_cc_m64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS
- CFLAGS="$CFLAGS -m64"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_cc_m64=yes
-else case e in #(
- e) tcl_cv_cc_m64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_m64" >&5
-printf "%s\n" "$tcl_cv_cc_m64" >&6; }
- if test $tcl_cv_cc_m64 = yes
-then :
-
- CFLAGS="$CFLAGS -m64"
- do64bit_ok=yes
-
-fi
-
-fi
-
- # The combo of gcc + glibc has a bug related to inlining of
- # functions like strtol()/strtoul(). The -fno-builtin flag should address
- # this problem but it does not work. The -fno-inline flag is kind
- # of overkill but it works. Disable inlining only when one of the
- # files in compat/*.c is being linked in.
-
- if test x"${USE_COMPAT}" != x
-then :
- CFLAGS="$CFLAGS -fno-inline"
-fi
- ;;
- Lynx*)
- SHLIB_CFLAGS="-fPIC"
- SHLIB_SUFFIX=".so"
- CFLAGS_OPTIMIZE=-02
- SHLIB_LD='${CC} -shared'
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-mshared -ldl"
- LD_FLAGS="-Wl,--export-dynamic"
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
- LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
-fi
- ;;
- OpenBSD-*)
- arch=`arch -s`
- case "$arch" in
- alpha|sparc64)
- SHLIB_CFLAGS="-fPIC"
- ;;
- *)
- SHLIB_CFLAGS="-fpic"
- ;;
- esac
- SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
-fi
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
- LDFLAGS="-Wl,-export-dynamic"
- CFLAGS_OPTIMIZE="-O2"
- # On OpenBSD: Compile with -pthread
- # Don't link with -lpthread
- LIBS=`echo $LIBS | sed s/-lpthread//`
- CFLAGS="$CFLAGS -pthread"
- # OpenBSD doesn't do version numbers with dots.
- UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
- TCL_LIB_VERSIONS_OK=nodots
- ;;
- NetBSD-*)
- # NetBSD has ELF and can use 'cc -shared' to build shared libs
- SHLIB_CFLAGS="-fPIC"
- SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- LDFLAGS="$LDFLAGS -export-dynamic"
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
-fi
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- # The -pthread needs to go in the CFLAGS, not LIBS
- LIBS=`echo $LIBS | sed s/-pthread//`
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
- ;;
- Darwin-*)
- CFLAGS_OPTIMIZE="-O2"
- SHLIB_CFLAGS="-fno-common"
- # To avoid discrepancies between what headers configure sees during
- # preprocessing tests and compiling tests, move any -isysroot and
- # -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
- CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \
- awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
- if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`"
- CFLAGS="`echo " ${CFLAGS}" | \
- awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
- if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`"
- if test $do64bit = yes
-then :
-
- case `arch` in
- ppc)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch ppc64 flag" >&5
-printf %s "checking if compiler accepts -arch ppc64 flag... " >&6; }
-if test ${tcl_cv_cc_arch_ppc64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS
- CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_cc_arch_ppc64=yes
-else case e in #(
- e) tcl_cv_cc_arch_ppc64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_ppc64" >&5
-printf "%s\n" "$tcl_cv_cc_arch_ppc64" >&6; }
- if test $tcl_cv_cc_arch_ppc64 = yes
-then :
-
- CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
- do64bit_ok=yes
-
-fi;;
- i386|x86_64)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch x86_64 flag" >&5
-printf %s "checking if compiler accepts -arch x86_64 flag... " >&6; }
-if test ${tcl_cv_cc_arch_x86_64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS
- CFLAGS="$CFLAGS -arch x86_64"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_cc_arch_x86_64=yes
-else case e in #(
- e) tcl_cv_cc_arch_x86_64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_x86_64" >&5
-printf "%s\n" "$tcl_cv_cc_arch_x86_64" >&6; }
- if test $tcl_cv_cc_arch_x86_64 = yes
-then :
-
- CFLAGS="$CFLAGS -arch x86_64"
- do64bit_ok=yes
-
-fi;;
- arm64)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if compiler accepts -arch arm64 flag" >&5
-printf %s "checking if compiler accepts -arch arm64 flag... " >&6; }
-if test ${tcl_cv_cc_arch_arm64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS
- CFLAGS="$CFLAGS -arch arm64"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_cc_arch_arm64=yes
-else case e in #(
- e) tcl_cv_cc_arch_arm64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_arch_arm64" >&5
-printf "%s\n" "$tcl_cv_cc_arch_arm64" >&6; }
- if test $tcl_cv_cc_arch_arm64 = yes
-then :
-
- CFLAGS="$CFLAGS -arch arm64"
- do64bit_ok=yes
-
-fi;;
- *)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5
-printf "%s\n" "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};;
- esac
-
-else case e in #(
- e)
- # Check for combined 32-bit and 64-bit fat build
- if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64|arm64) ' \
- && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '
-then :
-
- fat_32_64=yes
-fi
- ;;
-esac
-fi
- SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -single_module flag" >&5
-printf %s "checking if ld accepts -single_module flag... " >&6; }
-if test ${tcl_cv_ld_single_module+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_ldflags=$LDFLAGS
- LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-int i;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_ld_single_module=yes
-else case e in #(
- e) tcl_cv_ld_single_module=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- LDFLAGS=$hold_ldflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_single_module" >&5
-printf "%s\n" "$tcl_cv_ld_single_module" >&6; }
- if test $tcl_cv_ld_single_module = yes
-then :
-
- SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
-
-fi
- SHLIB_SUFFIX=".dylib"
- DL_OBJS="tclLoadDyld.o"
- DL_LIBS=""
- LDFLAGS="$LDFLAGS -headerpad_max_install_names"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if ld accepts -search_paths_first flag" >&5
-printf %s "checking if ld accepts -search_paths_first flag... " >&6; }
-if test ${tcl_cv_ld_search_paths_first+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_ldflags=$LDFLAGS
- LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-int i;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_ld_search_paths_first=yes
-else case e in #(
- e) tcl_cv_ld_search_paths_first=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- LDFLAGS=$hold_ldflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_search_paths_first" >&5
-printf "%s\n" "$tcl_cv_ld_search_paths_first" >&6; }
- if test $tcl_cv_ld_search_paths_first = yes
-then :
-
- LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
-
-fi
- if test "$tcl_cv_cc_visibility_hidden" != yes
-then :
-
-
-printf "%s\n" "#define MODULE_SCOPE __private_extern__" >>confdefs.h
-
- tcl_cv_cc_visibility_hidden=yes
-
-fi
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- LD_LIBRARY_PATH_VAR="DYLD_FALLBACK_LIBRARY_PATH"
-
-printf "%s\n" "#define MAC_OSX_TCL 1" >>confdefs.h
-
- PLAT_OBJS='${MAC_OSX_OBJS}'
- PLAT_SRCS='${MAC_OSX_SRCS}'
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use CoreFoundation" >&5
-printf %s "checking whether to use CoreFoundation... " >&6; }
- # Check whether --enable-corefoundation was given.
-if test ${enable_corefoundation+y}
-then :
- enableval=$enable_corefoundation; tcl_corefoundation=$enableval
-else case e in #(
- e) tcl_corefoundation=yes ;;
-esac
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_corefoundation" >&5
-printf "%s\n" "$tcl_corefoundation" >&6; }
- if test $tcl_corefoundation = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for CoreFoundation.framework" >&5
-printf %s "checking for CoreFoundation.framework... " >&6; }
-if test ${tcl_cv_lib_corefoundation+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_libs=$LIBS
- if test "$fat_32_64" = yes
-then :
-
- for v in CFLAGS CPPFLAGS LDFLAGS; do
- # On Tiger there is no 64-bit CF, so remove 64-bit
- # archs from CFLAGS et al. while testing for
- # presence of CF. 64-bit CF is disabled in
- # tclUnixPort.h if necessary.
- eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"'
- done
-fi
- LIBS="$LIBS -framework CoreFoundation"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-CFBundleRef b = CFBundleGetMainBundle();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_lib_corefoundation=yes
-else case e in #(
- e) tcl_cv_lib_corefoundation=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- if test "$fat_32_64" = yes
-then :
-
- for v in CFLAGS CPPFLAGS LDFLAGS; do
- eval $v'="$hold_'$v'"'
- done
-fi
- LIBS=$hold_libs ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation" >&5
-printf "%s\n" "$tcl_cv_lib_corefoundation" >&6; }
- if test $tcl_cv_lib_corefoundation = yes
-then :
-
- LIBS="$LIBS -framework CoreFoundation"
-
-printf "%s\n" "#define HAVE_COREFOUNDATION 1" >>confdefs.h
-
-
-else case e in #(
- e) tcl_corefoundation=no ;;
-esac
-fi
- if test "$fat_32_64" = yes -a $tcl_corefoundation = yes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit CoreFoundation" >&5
-printf %s "checking for 64-bit CoreFoundation... " >&6; }
-if test ${tcl_cv_lib_corefoundation_64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- for v in CFLAGS CPPFLAGS LDFLAGS; do
- eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"'
- done
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-CFBundleRef b = CFBundleGetMainBundle();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_lib_corefoundation_64=yes
-else case e in #(
- e) tcl_cv_lib_corefoundation_64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- for v in CFLAGS CPPFLAGS LDFLAGS; do
- eval $v'="$hold_'$v'"'
- done ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_lib_corefoundation_64" >&5
-printf "%s\n" "$tcl_cv_lib_corefoundation_64" >&6; }
- if test $tcl_cv_lib_corefoundation_64 = no
-then :
-
-
-printf "%s\n" "#define NO_COREFOUNDATION_64 1" >>confdefs.h
-
- LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings"
-
-fi
-
-fi
-
-fi
- ;;
- OS/390-*)
- SHLIB_LD_LIBS=""
- CFLAGS_OPTIMIZE="" # Optimizer is buggy
-
-printf "%s\n" "#define _OE_SOCKETS 1" >>confdefs.h
-
- ;;
- OSF1-V*)
- # Digital OSF/1
- SHLIB_CFLAGS=""
- if test "$SHARED_BUILD" = 1
-then :
-
- SHLIB_LD='${CC} -shared'
-
-else case e in #(
- e)
- SHLIB_LD='${CC} -non_shared'
- ;;
-esac
-fi
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- if test $doRpath = yes
-then :
-
- CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
- LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
-fi
- if test "$GCC" = yes
-then :
- CFLAGS="$CFLAGS -mieee"
-else case e in #(
- e)
- CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" ;;
-esac
-fi
- # see pthread_intro(3) for pthread support on osf1, k.furukawa
- CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
- CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
- LIBS=`echo $LIBS | sed s/-lpthreads//`
- if test "$GCC" = yes
-then :
-
- LIBS="$LIBS -lpthread -lmach -lexc"
-
-else case e in #(
- e)
- CFLAGS="$CFLAGS -pthread"
- LDFLAGS="$LDFLAGS -pthread"
- ;;
-esac
-fi
- ;;
- QNX-6*)
- # QNX RTP
- # This may work for all QNX, but it was only reported for v6.
- SHLIB_LD="ld -Bshareable -x"
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- # dlopen is in -lc on QNX
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- SCO_SV-3.2*)
- # Note, dlopen is available only on SCO 3.2.5 and greater. However,
- # this test works, since "uname -s" was non-standard in 3.2.4 and
- # below.
- if test "$GCC" = yes
-then :
-
- SHLIB_CFLAGS="-fPIC -melf"
- LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
-
-else case e in #(
- e)
- SHLIB_CFLAGS="-Kpic -belf"
- LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
- ;;
-esac
-fi
- SHLIB_LD="ld -G"
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- SunOS-5.[0-6])
- # Careful to not let 5.10+ fall into this case
-
- # Note: If _REENTRANT isn't defined, then Solaris
- # won't define thread-safe library routines.
-
-
-printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-
-
-printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
-
-
- SHLIB_CFLAGS="-KPIC"
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- if test "$GCC" = yes
-then :
-
- SHLIB_LD='${CC} -shared'
- CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
-
-else case e in #(
- e)
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
- CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- ;;
-esac
-fi
- ;;
- SunOS-5*)
- # Note: If _REENTRANT isn't defined, then Solaris
- # won't define thread-safe library routines.
-
-
-printf "%s\n" "#define _REENTRANT 1" >>confdefs.h
-
-
-printf "%s\n" "#define _POSIX_PTHREAD_SEMANTICS 1" >>confdefs.h
-
-
- SHLIB_CFLAGS="-KPIC"
-
- # Check to enable 64-bit flags for compiler/linker
- if test "$do64bit" = yes
-then :
-
- arch=`isainfo`
- if test "$arch" = "sparcv9 sparc"
-then :
-
- if test "$GCC" = yes
-then :
-
- if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;}
-
-else case e in #(
- e)
- do64bit_ok=yes
- CFLAGS="$CFLAGS -m64 -mcpu=v9"
- LDFLAGS="$LDFLAGS -m64 -mcpu=v9"
- SHLIB_CFLAGS="-fPIC"
- ;;
-esac
-fi
-
-else case e in #(
- e)
- do64bit_ok=yes
- if test "$do64bitVIS" = yes
-then :
-
- CFLAGS="$CFLAGS -xarch=v9a"
- LDFLAGS_ARCH="-xarch=v9a"
-
-else case e in #(
- e)
- CFLAGS="$CFLAGS -xarch=v9"
- LDFLAGS_ARCH="-xarch=v9"
- ;;
-esac
-fi
- # Solaris 64 uses this as well
- #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64"
- ;;
-esac
-fi
-
-else case e in #(
- e) if test "$arch" = "amd64 i386"
-then :
-
- if test "$GCC" = yes
-then :
-
- case $system in
- SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*)
- do64bit_ok=yes
- CFLAGS="$CFLAGS -m64"
- LDFLAGS="$LDFLAGS -m64";;
- *)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};;
- esac
-
-else case e in #(
- e)
- do64bit_ok=yes
- case $system in
- SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*)
- CFLAGS="$CFLAGS -m64"
- LDFLAGS="$LDFLAGS -m64";;
- *)
- CFLAGS="$CFLAGS -xarch=amd64"
- LDFLAGS="$LDFLAGS -xarch=amd64";;
- esac
- ;;
-esac
-fi
-
-else case e in #(
- e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported for $arch" >&5
-printf "%s\n" "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} ;;
-esac
-fi ;;
-esac
-fi
-
-fi
-
- #--------------------------------------------------------------------
- # On Solaris 5.x i386 with the sunpro compiler we need to link
- # with sunmath to get floating point rounding control
- #--------------------------------------------------------------------
- if test "$GCC" = yes
-then :
- use_sunmath=no
-else case e in #(
- e)
- arch=`isainfo`
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether to use -lsunmath for fp rounding control" >&5
-printf %s "checking whether to use -lsunmath for fp rounding control... " >&6; }
- if test "$arch" = "amd64 i386" -o "$arch" = "i386"
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
-printf "%s\n" "yes" >&6; }
- MATH_LIBS="-lsunmath $MATH_LIBS"
- ac_fn_c_check_header_compile "$LINENO" "sunmath.h" "ac_cv_header_sunmath_h" "$ac_includes_default"
-if test "x$ac_cv_header_sunmath_h" = xyes
-then :
-
-fi
-
- use_sunmath=yes
-
-else case e in #(
- e)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
- use_sunmath=no
- ;;
-esac
-fi
- ;;
-esac
-fi
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- if test "$GCC" = yes
-then :
-
- SHLIB_LD='${CC} -shared'
- CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
- if test "$do64bit_ok" = yes
-then :
-
- if test "$arch" = "sparcv9 sparc"
-then :
-
- # We need to specify -static-libgcc or we need to
- # add the path to the sparv9 libgcc.
- SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc"
- # for finding sparcv9 libgcc, get the regular libgcc
- # path, remove so name and append 'sparcv9'
- #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
- #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
-
-else case e in #(
- e) if test "$arch" = "amd64 i386"
-then :
-
- SHLIB_LD="$SHLIB_LD -m64 -static-libgcc"
-
-fi ;;
-esac
-fi
-
-fi
-
-else case e in #(
- e)
- if test "$use_sunmath" = yes
-then :
- textmode=textoff
-else case e in #(
- e) textmode=text ;;
-esac
-fi
- case $system in
- SunOS-5.[1-9][0-9]*|SunOS-5.[7-9])
- SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";;
- *)
- SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";;
- esac
- CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
- LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
- ;;
-esac
-fi
- ;;
- UNIX_SV* | UnixWare-5*)
- SHLIB_CFLAGS="-KPIC"
- SHLIB_LD='${CC} -G'
- SHLIB_LD_LIBS=""
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
- # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
- # that don't grok the -Bexport option. Test that it does.
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ld accepts -Bexport flag" >&5
-printf %s "checking for ld accepts -Bexport flag... " >&6; }
-if test ${tcl_cv_ld_Bexport+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_ldflags=$LDFLAGS
- LDFLAGS="$LDFLAGS -Wl,-Bexport"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-int i;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- tcl_cv_ld_Bexport=yes
-else case e in #(
- e) tcl_cv_ld_Bexport=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
- LDFLAGS=$hold_ldflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_Bexport" >&5
-printf "%s\n" "$tcl_cv_ld_Bexport" >&6; }
- if test $tcl_cv_ld_Bexport = yes
-then :
-
- LDFLAGS="$LDFLAGS -Wl,-Bexport"
-
-fi
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- ;;
- esac
-
- if test "$do64bit" = yes -a "$do64bit_ok" = no
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5
-printf "%s\n" "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;}
-
-fi
-
- if test "$do64bit" = yes -a "$do64bit_ok" = yes
-then :
-
-
-printf "%s\n" "#define TCL_CFG_DO64BIT 1" >>confdefs.h
-
-
-fi
-
-
-
- # Step 4: disable dynamic loading if requested via a command-line switch.
-
- # Check whether --enable-load was given.
-if test ${enable_load+y}
-then :
- enableval=$enable_load; tcl_ok=$enableval
-else case e in #(
- e) tcl_ok=yes ;;
-esac
-fi
-
- if test "$tcl_ok" = no
-then :
- DL_OBJS=""
-fi
-
- if test "x$DL_OBJS" != x
-then :
- BUILD_DLTEST="\$(DLTEST_TARGETS)"
-else case e in #(
- e)
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5
-printf "%s\n" "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;}
- SHLIB_CFLAGS=""
- SHLIB_LD=""
- SHLIB_SUFFIX=""
- DL_OBJS="tclLoadNone.o"
- DL_LIBS=""
- LDFLAGS="$LDFLAGS_ORIG"
- CC_SEARCH_FLAGS=""
- LD_SEARCH_FLAGS=""
- BUILD_DLTEST=""
- ;;
-esac
-fi
- LDFLAGS="$LDFLAGS $LDFLAGS_ARCH"
-
- # If we're running gcc, then change the C flags for compiling shared
- # libraries to the right flags for gcc, instead of those for the
- # standard manufacturer compiler.
-
- if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes
-then :
-
- case $system in
- AIX-*) ;;
- BSD/OS*) ;;
- CYGWIN_*|MINGW32_*|MSYS_*) ;;
- HP-UX*) ;;
- Darwin-*) ;;
- IRIX*) ;;
- Linux*|GNU*) ;;
- NetBSD-*|OpenBSD-*) ;;
- OSF1-*) ;;
- SCO_SV-3.2*) ;;
- *) SHLIB_CFLAGS="-fPIC" ;;
- esac
-fi
-
- if test "$tcl_cv_cc_visibility_hidden" != yes
-then :
-
-
-printf "%s\n" "#define MODULE_SCOPE extern" >>confdefs.h
-
-
-fi
-
- if test "$SHARED_LIB_SUFFIX" = ""
-then :
-
- SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
-fi
- if test "$UNSHARED_LIB_SUFFIX" = ""
-then :
-
- UNSHARED_LIB_SUFFIX='${VERSION}.a'
-fi
- DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
-
- if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""
-then :
-
- LIB_SUFFIX=${SHARED_LIB_SUFFIX}
- MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
- if test "${SHLIB_SUFFIX}" = ".dll"
-then :
-
- INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)"'
- DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
-
-else case e in #(
- e)
- INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
- ;;
-esac
-fi
-
-else case e in #(
- e)
- LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
-
- if test "$RANLIB" = ""
-then :
-
- MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
-
-else case e in #(
- e)
- MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
- ;;
-esac
-fi
- INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
- ;;
-esac
-fi
-
- # Stub lib does not depend on shared/static configuration
- if test "$RANLIB" = ""
-then :
-
- MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
-
-else case e in #(
- e)
- MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
- ;;
-esac
-fi
- INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"'
-
- # Define TCL_LIBS now that we know what DL_LIBS is.
- # The trick here is that we don't want to change the value of TCL_LIBS if
- # it is already set when tclConfig.sh had been loaded by Tk.
- if test "x${TCL_LIBS}" = x
-then :
-
- TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"
-fi
-
-
- # See if the compiler supports casting to a union type.
- # This is used to stop gcc from printing a compiler
- # warning when initializing a union member.
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
-printf %s "checking for cast to union support... " >&6; }
-if test ${tcl_cv_cast_to_union+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- union foo { int i; double d; };
- union foo f = (union foo) (int) 0;
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_cast_to_union=yes
-else case e in #(
- e) tcl_cv_cast_to_union=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
-printf "%s\n" "$tcl_cv_cast_to_union" >&6; }
- if test "$tcl_cv_cast_to_union" = "yes"; then
-
-printf "%s\n" "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
-
- fi
- hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto"
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for working -fno-lto" >&5
-printf %s "checking for working -fno-lto... " >&6; }
-if test ${ac_cv_nolto+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_nolto=yes
-else case e in #(
- e) ac_cv_nolto=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_nolto" >&5
-printf "%s\n" "$ac_cv_nolto" >&6; }
- CFLAGS=$hold_cflags
- if test "$ac_cv_nolto" = "yes" ; then
- CFLAGS_NOLTO="-fno-lto"
- else
- CFLAGS_NOLTO=""
- fi
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -finput-charset" >&5
-printf %s "checking if the compiler understands -finput-charset... " >&6; }
-if test ${tcl_cv_cc_input_charset+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_cc_input_charset=yes
-else case e in #(
- e) tcl_cv_cc_input_charset=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- CFLAGS=$hold_cflags ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cc_input_charset" >&5
-printf "%s\n" "$tcl_cv_cc_input_charset" >&6; }
- if test $tcl_cv_cc_input_charset = yes; then
- CFLAGS="$CFLAGS -finput-charset=UTF-8"
- fi
-
- ac_fn_c_check_header_compile "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
-if test "x$ac_cv_header_stdbool_h" = xyes
-then :
-
-printf "%s\n" "#define HAVE_STDBOOL_H 1" >>confdefs.h
-
-fi
-
-
- # Check for vfork, posix_spawnp() and friends unconditionally
- ac_fn_c_check_func "$LINENO" "vfork" "ac_cv_func_vfork"
-if test "x$ac_cv_func_vfork" = xyes
-then :
- printf "%s\n" "#define HAVE_VFORK 1" >>confdefs.h
-
-fi
-ac_fn_c_check_func "$LINENO" "posix_spawnp" "ac_cv_func_posix_spawnp"
-if test "x$ac_cv_func_posix_spawnp" = xyes
-then :
- printf "%s\n" "#define HAVE_POSIX_SPAWNP 1" >>confdefs.h
-
-fi
-ac_fn_c_check_func "$LINENO" "posix_spawn_file_actions_adddup2" "ac_cv_func_posix_spawn_file_actions_adddup2"
-if test "x$ac_cv_func_posix_spawn_file_actions_adddup2" = xyes
-then :
- printf "%s\n" "#define HAVE_POSIX_SPAWN_FILE_ACTIONS_ADDDUP2 1" >>confdefs.h
-
-fi
-ac_fn_c_check_func "$LINENO" "posix_spawnattr_setflags" "ac_cv_func_posix_spawnattr_setflags"
-if test "x$ac_cv_func_posix_spawnattr_setflags" = xyes
-then :
- printf "%s\n" "#define HAVE_POSIX_SPAWNATTR_SETFLAGS 1" >>confdefs.h
-
-fi
-
-
- # FIXME: This subst was left in only because the TCL_DL_LIBS
- # entry in tclConfig.sh uses it. It is not clear why someone
- # would use TCL_DL_LIBS instead of TCL_LIBS.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-printf "%s\n" "#define TCL_SHLIB_EXT \"${SHLIB_SUFFIX}\"" >>confdefs.h
-
-
-
-
-
-
-
-
-
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5
-printf %s "checking for build with symbols... " >&6; }
- # Check whether --enable-symbols was given.
-if test ${enable_symbols+y}
-then :
- enableval=$enable_symbols; tcl_ok=$enableval
-else case e in #(
- e) tcl_ok=no ;;
-esac
-fi
-
-# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
- if test "$tcl_ok" = "no"; then
- CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
- LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
-
-printf "%s\n" "#define NDEBUG 1" >>confdefs.h
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
-
-printf "%s\n" "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h
-
- else
- CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
- LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- if test "$tcl_ok" = "yes"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5
-printf "%s\n" "yes (standard debugging)" >&6; }
- fi
- fi
-
-
-
- if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
-
-printf "%s\n" "#define TCL_MEM_DEBUG 1" >>confdefs.h
-
- fi
-
- if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
-
-printf "%s\n" "#define TCL_COMPILE_DEBUG 1" >>confdefs.h
-
-
-printf "%s\n" "#define TCL_COMPILE_STATS 1" >>confdefs.h
-
- fi
-
- if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
- if test "$tcl_ok" = "all"; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5
-printf "%s\n" "enabled symbols mem compile debugging" >&6; }
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5
-printf "%s\n" "enabled $tcl_ok debugging" >&6; }
- fi
- fi
-
-
-
-printf "%s\n" "#define MP_PREC 4" >>confdefs.h
-
-
-#--------------------------------------------------------------------
-# Detect what compiler flags to set for 64-bit support.
-#--------------------------------------------------------------------
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for required early compiler flags" >&5
-printf %s "checking for required early compiler flags... " >&6; }
- tcl_flags=""
-
- if test ${tcl_cv_flag__isoc99_source+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-char *p = (char *)strtoll; char *q = (char *)strtoull;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__isoc99_source=no
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#define _ISOC99_SOURCE 1
-#include
-int
-main (void)
-{
-char *p = (char *)strtoll; char *q = (char *)strtoull;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__isoc99_source=yes
-else case e in #(
- e) tcl_cv_flag__isoc99_source=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then
-
-printf "%s\n" "#define _ISOC99_SOURCE 1" >>confdefs.h
-
- tcl_flags="$tcl_flags _ISOC99_SOURCE"
- fi
-
-
- if test ${tcl_cv_flag__file_offset_bits+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; }
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__file_offset_bits=no
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#define _FILE_OFFSET_BITS 64
-#include
-int
-main (void)
-{
-switch (0) { case 0: case (sizeof(off_t)==sizeof(long long)): ; }
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__file_offset_bits=yes
-else case e in #(
- e) tcl_cv_flag__file_offset_bits=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- if test "x${tcl_cv_flag__file_offset_bits}" = "xyes" ; then
-
-printf "%s\n" "#define _FILE_OFFSET_BITS 64" >>confdefs.h
-
- tcl_flags="$tcl_flags _FILE_OFFSET_BITS"
- fi
-
-
- if test ${tcl_cv_flag__largefile64_source+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-struct stat64 buf; int i = stat64("/", &buf);
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__largefile64_source=no
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#define _LARGEFILE64_SOURCE 1
-#include
-int
-main (void)
-{
-struct stat64 buf; int i = stat64("/", &buf);
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_flag__largefile64_source=yes
-else case e in #(
- e) tcl_cv_flag__largefile64_source=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then
-
-printf "%s\n" "#define _LARGEFILE64_SOURCE 1" >>confdefs.h
-
- tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
- fi
-
- if test "x${tcl_flags}" = "x" ; then
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none" >&5
-printf "%s\n" "none" >&6; }
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: ${tcl_flags}" >&5
-printf "%s\n" "${tcl_flags}" >&6; }
- fi
-
-
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if 'long' and 'long long' have the same size (64-bit)?" >&5
-printf %s "checking if 'long' and 'long long' have the same size (64-bit)?... " >&6; }
- if test ${tcl_cv_type_64bit+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- tcl_cv_type_64bit=none
- # See if we could use long anyway Note that we substitute in the
- # type that is our current guess for a 64-bit type inside this check
- # program, so it should be modified only carefully...
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-int
-main (void)
-{
-switch (0) {
- case 1: case (sizeof(long long)==sizeof(long)): ;
- }
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_type_64bit="long long"
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- if test "${tcl_cv_type_64bit}" = none ; then
-
-printf "%s\n" "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
-printf "%s\n" "yes" >&6; }
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
- # Now check for auxiliary declarations
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for 64-bit time_t" >&5
-printf %s "checking for 64-bit time_t... " >&6; }
-if test ${tcl_cv_time_t_64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_time_t_64=yes
-else case e in #(
- e) tcl_cv_time_t_64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_time_t_64" >&5
-printf "%s\n" "$tcl_cv_time_t_64" >&6; }
- if test "x${tcl_cv_time_t_64}" = "xno" ; then
- # Note that _TIME_BITS=64 requires _FILE_OFFSET_BITS=64
- # which SC_TCL_EARLY_FLAGS has defined if necessary.
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if _TIME_BITS=64 enables 64-bit time_t" >&5
-printf %s "checking if _TIME_BITS=64 enables 64-bit time_t... " >&6; }
-if test ${tcl_cv__time_bits+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#define _TIME_BITS 64
-#include
-int
-main (void)
-{
-switch (0) {case 0: case (sizeof(time_t)==sizeof(long long)): ;}
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv__time_bits=yes
-else case e in #(
- e) tcl_cv__time_bits=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv__time_bits" >&5
-printf "%s\n" "$tcl_cv__time_bits" >&6; }
- if test "x${tcl_cv__time_bits}" = "xyes" ; then
-
-printf "%s\n" "#define _TIME_BITS 64" >>confdefs.h
-
- fi
- fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for struct dirent64" >&5
-printf %s "checking for struct dirent64... " >&6; }
-if test ${tcl_cv_struct_dirent64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-#include
-int
-main (void)
-{
-struct dirent64 p;
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_struct_dirent64=yes
-else case e in #(
- e) tcl_cv_struct_dirent64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_struct_dirent64" >&5
-printf "%s\n" "$tcl_cv_struct_dirent64" >&6; }
- if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
-
-printf "%s\n" "#define HAVE_STRUCT_DIRENT64 1" >>confdefs.h
-
- fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for DIR64" >&5
-printf %s "checking for DIR64... " >&6; }
-if test ${tcl_cv_DIR64+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-#include
-int
-main (void)
-{
-struct dirent64 *p; DIR64 d = opendir64(".");
- p = readdir64(d); rewinddir64(d); closedir64(d);
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_DIR64=yes
-else case e in #(
- e) tcl_cv_DIR64=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_DIR64" >&5
-printf "%s\n" "$tcl_cv_DIR64" >&6; }
- if test "x${tcl_cv_DIR64}" = "xyes" ; then
-
-printf "%s\n" "#define HAVE_DIR64 1" >>confdefs.h
-
- fi
-
- ac_fn_c_check_func "$LINENO" "open64" "ac_cv_func_open64"
-if test "x$ac_cv_func_open64" = xyes
-then :
- printf "%s\n" "#define HAVE_OPEN64 1" >>confdefs.h
-
-fi
-ac_fn_c_check_func "$LINENO" "lseek64" "ac_cv_func_lseek64"
-if test "x$ac_cv_func_lseek64" = xyes
-then :
- printf "%s\n" "#define HAVE_LSEEK64 1" >>confdefs.h
-
-fi
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for off64_t" >&5
-printf %s "checking for off64_t... " >&6; }
- if test ${tcl_cv_type_off64_t+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-int
-main (void)
-{
-off64_t offset;
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_type_off64_t=yes
-else case e in #(
- e) tcl_cv_type_off64_t=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- if test "x${tcl_cv_type_off64_t}" = "xyes" && \
- test "x${ac_cv_func_lseek64}" = "xyes" && \
- test "x${ac_cv_func_open64}" = "xyes" ; then
-
-printf "%s\n" "#define HAVE_TYPE_OFF64_T 1" >>confdefs.h
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
-printf "%s\n" "yes" >&6; }
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
-printf "%s\n" "no" >&6; }
- fi
- fi
-
-
-#--------------------------------------------------------------------
-# Check endianness because we can optimize comparisons of
-# Tcl_UniChar strings to memcmp on big-endian systems.
-#--------------------------------------------------------------------
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5
-printf %s "checking whether byte ordering is bigendian... " >&6; }
-if test ${ac_cv_c_bigendian+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e) ac_cv_c_bigendian=unknown
- # See if we're dealing with a universal compiler.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#ifndef __APPLE_CC__
- not a universal capable compiler
- #endif
- typedef int dummy;
-
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
-
- # Check for potential -arch flags. It is not universal unless
- # there are at least two -arch flags with different values.
- ac_arch=
- ac_prev=
- for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do
- if test -n "$ac_prev"; then
- case $ac_word in
- i?86 | x86_64 | ppc | ppc64)
- if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then
- ac_arch=$ac_word
- else
- ac_cv_c_bigendian=universal
- break
- fi
- ;;
- esac
- ac_prev=
- elif test "x$ac_word" = "x-arch"; then
- ac_prev=arch
- fi
- done
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- if test $ac_cv_c_bigendian = unknown; then
- # See if sys/param.h defines the BYTE_ORDER macro.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
- #include
-
-int
-main (void)
-{
-#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \\
- && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \\
- && LITTLE_ENDIAN)
- bogus endian macros
- #endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- # It does; now see whether it defined to BIG_ENDIAN or not.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
- #include
-
-int
-main (void)
-{
-#if BYTE_ORDER != BIG_ENDIAN
- not big endian
- #endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_c_bigendian=yes
-else case e in #(
- e) ac_cv_c_bigendian=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- fi
- if test $ac_cv_c_bigendian = unknown; then
- # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris).
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-
-int
-main (void)
-{
-#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN)
- bogus endian macros
- #endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- # It does; now see whether it defined to _BIG_ENDIAN or not.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-#include
-
-int
-main (void)
-{
-#ifndef _BIG_ENDIAN
- not big endian
- #endif
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- ac_cv_c_bigendian=yes
-else case e in #(
- e) ac_cv_c_bigendian=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
- fi
- if test $ac_cv_c_bigendian = unknown; then
- # Compile a test program.
- if test "$cross_compiling" = yes
-then :
- # Try to guess by grepping values from an object file.
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-unsigned short int ascii_mm[] =
- { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 };
- unsigned short int ascii_ii[] =
- { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 };
- int use_ascii (int i) {
- return ascii_mm[i] + ascii_ii[i];
- }
- unsigned short int ebcdic_ii[] =
- { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 };
- unsigned short int ebcdic_mm[] =
- { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 };
- int use_ebcdic (int i) {
- return ebcdic_mm[i] + ebcdic_ii[i];
- }
- int
- main (int argc, char **argv)
- {
- /* Intimidate the compiler so that it does not
- optimize the arrays away. */
- char *p = argv[0];
- ascii_mm[1] = *p++; ebcdic_mm[1] = *p++;
- ascii_ii[1] = *p++; ebcdic_ii[1] = *p++;
- return use_ascii (argc) == use_ebcdic (*p);
- }
-_ACEOF
-if ac_fn_c_try_link "$LINENO"
-then :
- if grep BIGenDianSyS conftest$ac_exeext >/dev/null; then
- ac_cv_c_bigendian=yes
- fi
- if grep LiTTleEnDian conftest$ac_exeext >/dev/null ; then
- if test "$ac_cv_c_bigendian" = unknown; then
- ac_cv_c_bigendian=no
- else
- # finding both strings is unlikely to happen, but who knows?
- ac_cv_c_bigendian=unknown
- fi
- fi
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam \
- conftest$ac_exeext conftest.$ac_ext
-else case e in #(
- e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-$ac_includes_default
-int
-main (void)
-{
-
- /* Are we little or big endian? From Harbison&Steele. */
- union
- {
- long int l;
- char c[sizeof (long int)];
- } u;
- u.l = 1;
- return u.c[sizeof (long int) - 1] == 1;
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_run "$LINENO"
-then :
- ac_cv_c_bigendian=no
-else case e in #(
- e) ac_cv_c_bigendian=yes ;;
-esac
-fi
-rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
- conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-
- fi ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5
-printf "%s\n" "$ac_cv_c_bigendian" >&6; }
- case $ac_cv_c_bigendian in #(
- yes)
- printf "%s\n" "#define WORDS_BIGENDIAN 1" >>confdefs.h
-;; #(
- no)
- ;; #(
- universal)
- #
- ;; #(
- *)
- as_fn_error $? "unknown endianness
- presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;;
- esac
-
-
-#--------------------------------------------------------------------
-# Supply substitutes for missing POSIX library procedures, or
-# set flags so Tcl uses alternate procedures.
-#--------------------------------------------------------------------
-
-# Check if Posix compliant getcwd exists, if not we'll use getwd.
-
- for ac_func in getcwd
-do :
- ac_fn_c_check_func "$LINENO" "getcwd" "ac_cv_func_getcwd"
-if test "x$ac_cv_func_getcwd" = xyes
-then :
- printf "%s\n" "#define HAVE_GETCWD 1" >>confdefs.h
-
-else case e in #(
- e)
-printf "%s\n" "#define USEGETWD 1" >>confdefs.h
- ;;
-esac
-fi
-
-done
-# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
-# define USEGETWD even if the posix getcwd exists. Add a test ?
-
-ac_fn_c_check_func "$LINENO" "mkstemp" "ac_cv_func_mkstemp"
-if test "x$ac_cv_func_mkstemp" = xyes
-then :
- printf "%s\n" "#define HAVE_MKSTEMP 1" >>confdefs.h
-
-else case e in #(
- e) case " $LIBOBJS " in
- *" mkstemp.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
- ;;
-esac
- ;;
-esac
-fi
-ac_fn_c_check_func "$LINENO" "waitpid" "ac_cv_func_waitpid"
-if test "x$ac_cv_func_waitpid" = xyes
-then :
- printf "%s\n" "#define HAVE_WAITPID 1" >>confdefs.h
-
-else case e in #(
- e) case " $LIBOBJS " in
- *" waitpid.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS waitpid.$ac_objext"
- ;;
-esac
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "strerror" "ac_cv_func_strerror"
-if test "x$ac_cv_func_strerror" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_STRERROR 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd"
-if test "x$ac_cv_func_getwd" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_GETWD 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "wait3" "ac_cv_func_wait3"
-if test "x$ac_cv_func_wait3" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_WAIT3 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "fork" "ac_cv_func_fork"
-if test "x$ac_cv_func_fork" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_FORK 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "mknod" "ac_cv_func_mknod"
-if test "x$ac_cv_func_mknod" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_MKNOD 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "tcdrain" "ac_cv_func_tcdrain"
-if test "x$ac_cv_func_tcdrain" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_TCDRAIN 1" >>confdefs.h
- ;;
-esac
-fi
-
-ac_fn_c_check_func "$LINENO" "uname" "ac_cv_func_uname"
-if test "x$ac_cv_func_uname" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_UNAME 1" >>confdefs.h
- ;;
-esac
-fi
-
-
-if test "`uname -s`" = "Darwin" && \
- test "`uname -r | awk -F. '{print $1}'`" -lt 7; then
- # prior to Darwin 7, realpath is not threadsafe, so don't
- # use it when threads are enabled, c.f. bug # 711232
- ac_cv_func_realpath=no
-fi
-ac_fn_c_check_func "$LINENO" "realpath" "ac_cv_func_realpath"
-if test "x$ac_cv_func_realpath" = xyes
-then :
-
-else case e in #(
- e)
-printf "%s\n" "#define NO_REALPATH 1" >>confdefs.h
- ;;
-esac
-fi
-
-
-
- NEED_FAKE_RFC2553=0
-
- for ac_func in getnameinfo getaddrinfo freeaddrinfo gai_strerror
-do :
- as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | sed "$as_sed_sh"`
-ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
-if eval test \"x\$"$as_ac_var"\" = x"yes"
-then :
- cat >>confdefs.h <<_ACEOF
-#define `printf "%s\n" "HAVE_$ac_func" | sed "$as_sed_cpp"` 1
-_ACEOF
-
-else case e in #(
- e) NEED_FAKE_RFC2553=1 ;;
-esac
-fi
-
-done
- ac_fn_c_check_type "$LINENO" "struct addrinfo" "ac_cv_type_struct_addrinfo" "
-#include
-#include
-#include
-#include
-
-"
-if test "x$ac_cv_type_struct_addrinfo" = xyes
-then :
-
-printf "%s\n" "#define HAVE_STRUCT_ADDRINFO 1" >>confdefs.h
-
-
-else case e in #(
- e) NEED_FAKE_RFC2553=1 ;;
-esac
-fi
-ac_fn_c_check_type "$LINENO" "struct in6_addr" "ac_cv_type_struct_in6_addr" "
-#include
-#include
-#include
-#include
-
-"
-if test "x$ac_cv_type_struct_in6_addr" = xyes
-then :
-
-printf "%s\n" "#define HAVE_STRUCT_IN6_ADDR 1" >>confdefs.h
-
-
-else case e in #(
- e) NEED_FAKE_RFC2553=1 ;;
-esac
-fi
-ac_fn_c_check_type "$LINENO" "struct sockaddr_in6" "ac_cv_type_struct_sockaddr_in6" "
-#include
-#include
-#include
-#include
-
-"
-if test "x$ac_cv_type_struct_sockaddr_in6" = xyes
-then :
-
-printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_IN6 1" >>confdefs.h
-
-
-else case e in #(
- e) NEED_FAKE_RFC2553=1 ;;
-esac
-fi
-ac_fn_c_check_type "$LINENO" "struct sockaddr_storage" "ac_cv_type_struct_sockaddr_storage" "
-#include
-#include
-#include
-#include
-
-"
-if test "x$ac_cv_type_struct_sockaddr_storage" = xyes
-then :
-
-printf "%s\n" "#define HAVE_STRUCT_SOCKADDR_STORAGE 1" >>confdefs.h
-
-
-else case e in #(
- e) NEED_FAKE_RFC2553=1 ;;
-esac
-fi
-
-if test "x$NEED_FAKE_RFC2553" = "x1"; then
-
-printf "%s\n" "#define NEED_FAKE_RFC2553 1" >>confdefs.h
-
- case " $LIBOBJS " in
- *" fake-rfc2553.$ac_objext "* ) ;;
- *) LIBOBJS="$LIBOBJS fake-rfc2553.$ac_objext"
- ;;
-esac
-
- ac_fn_c_check_func "$LINENO" "strlcpy" "ac_cv_func_strlcpy"
-if test "x$ac_cv_func_strlcpy" = xyes
-then :
-
-fi
-
-fi
-
-
-#--------------------------------------------------------------------
-# Look for thread-safe variants of some library functions.
-#--------------------------------------------------------------------
-
-ac_fn_c_check_func "$LINENO" "getpwuid_r" "ac_cv_func_getpwuid_r"
-if test "x$ac_cv_func_getpwuid_r" = xyes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 5 args" >&5
-printf %s "checking for getpwuid_r with 5 args... " >&6; }
-if test ${tcl_cv_api_getpwuid_r_5+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- uid_t uid;
- struct passwd pw, *pwp;
- char buf[512];
- int buflen = 512;
-
- (void) getpwuid_r(uid, &pw, buf, buflen, &pwp);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getpwuid_r_5=yes
-else case e in #(
- e) tcl_cv_api_getpwuid_r_5=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_5" >&5
-printf "%s\n" "$tcl_cv_api_getpwuid_r_5" >&6; }
- tcl_ok=$tcl_cv_api_getpwuid_r_5
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWUID_R_5 1" >>confdefs.h
-
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwuid_r with 4 args" >&5
-printf %s "checking for getpwuid_r with 4 args... " >&6; }
-if test ${tcl_cv_api_getpwuid_r_4+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- uid_t uid;
- struct passwd pw;
- char buf[512];
- int buflen = 512;
-
- (void)getpwnam_r(uid, &pw, buf, buflen);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getpwuid_r_4=yes
-else case e in #(
- e) tcl_cv_api_getpwuid_r_4=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwuid_r_4" >&5
-printf "%s\n" "$tcl_cv_api_getpwuid_r_4" >&6; }
- tcl_ok=$tcl_cv_api_getpwuid_r_4
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWUID_R_4 1" >>confdefs.h
-
- fi
- fi
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWUID_R 1" >>confdefs.h
-
- fi
-
-fi
-
-ac_fn_c_check_func "$LINENO" "getpwnam_r" "ac_cv_func_getpwnam_r"
-if test "x$ac_cv_func_getpwnam_r" = xyes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 5 args" >&5
-printf %s "checking for getpwnam_r with 5 args... " >&6; }
-if test ${tcl_cv_api_getpwnam_r_5+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- char *name;
- struct passwd pw, *pwp;
- char buf[512];
- int buflen = 512;
-
- (void) getpwnam_r(name, &pw, buf, buflen, &pwp);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getpwnam_r_5=yes
-else case e in #(
- e) tcl_cv_api_getpwnam_r_5=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_5" >&5
-printf "%s\n" "$tcl_cv_api_getpwnam_r_5" >&6; }
- tcl_ok=$tcl_cv_api_getpwnam_r_5
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWNAM_R_5 1" >>confdefs.h
-
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getpwnam_r with 4 args" >&5
-printf %s "checking for getpwnam_r with 4 args... " >&6; }
-if test ${tcl_cv_api_getpwnam_r_4+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- char *name;
- struct passwd pw;
- char buf[512];
- int buflen = 512;
-
- (void)getpwnam_r(name, &pw, buf, buflen);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getpwnam_r_4=yes
-else case e in #(
- e) tcl_cv_api_getpwnam_r_4=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getpwnam_r_4" >&5
-printf "%s\n" "$tcl_cv_api_getpwnam_r_4" >&6; }
- tcl_ok=$tcl_cv_api_getpwnam_r_4
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWNAM_R_4 1" >>confdefs.h
-
- fi
- fi
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETPWNAM_R 1" >>confdefs.h
-
- fi
-
-fi
-
-ac_fn_c_check_func "$LINENO" "getgrgid_r" "ac_cv_func_getgrgid_r"
-if test "x$ac_cv_func_getgrgid_r" = xyes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 5 args" >&5
-printf %s "checking for getgrgid_r with 5 args... " >&6; }
-if test ${tcl_cv_api_getgrgid_r_5+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- gid_t gid;
- struct group gr, *grp;
- char buf[512];
- int buflen = 512;
-
- (void) getgrgid_r(gid, &gr, buf, buflen, &grp);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getgrgid_r_5=yes
-else case e in #(
- e) tcl_cv_api_getgrgid_r_5=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_5" >&5
-printf "%s\n" "$tcl_cv_api_getgrgid_r_5" >&6; }
- tcl_ok=$tcl_cv_api_getgrgid_r_5
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRGID_R_5 1" >>confdefs.h
-
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrgid_r with 4 args" >&5
-printf %s "checking for getgrgid_r with 4 args... " >&6; }
-if test ${tcl_cv_api_getgrgid_r_4+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- gid_t gid;
- struct group gr;
- char buf[512];
- int buflen = 512;
-
- (void)getgrgid_r(gid, &gr, buf, buflen);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getgrgid_r_4=yes
-else case e in #(
- e) tcl_cv_api_getgrgid_r_4=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrgid_r_4" >&5
-printf "%s\n" "$tcl_cv_api_getgrgid_r_4" >&6; }
- tcl_ok=$tcl_cv_api_getgrgid_r_4
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRGID_R_4 1" >>confdefs.h
-
- fi
- fi
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRGID_R 1" >>confdefs.h
-
- fi
-
-fi
-
-ac_fn_c_check_func "$LINENO" "getgrnam_r" "ac_cv_func_getgrnam_r"
-if test "x$ac_cv_func_getgrnam_r" = xyes
-then :
-
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 5 args" >&5
-printf %s "checking for getgrnam_r with 5 args... " >&6; }
-if test ${tcl_cv_api_getgrnam_r_5+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- char *name;
- struct group gr, *grp;
- char buf[512];
- int buflen = 512;
-
- (void) getgrnam_r(name, &gr, buf, buflen, &grp);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getgrnam_r_5=yes
-else case e in #(
- e) tcl_cv_api_getgrnam_r_5=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_5" >&5
-printf "%s\n" "$tcl_cv_api_getgrnam_r_5" >&6; }
- tcl_ok=$tcl_cv_api_getgrnam_r_5
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRNAM_R_5 1" >>confdefs.h
-
- else
- { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for getgrnam_r with 4 args" >&5
-printf %s "checking for getgrnam_r with 4 args... " >&6; }
-if test ${tcl_cv_api_getgrnam_r_4+y}
-then :
- printf %s "(cached) " >&6
-else case e in #(
- e)
- cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
- #include
- #include
-
-int
-main (void)
-{
-
- char *name;
- struct group gr;
- char buf[512];
- int buflen = 512;
-
- (void)getgrnam_r(name, &gr, buf, buflen);
-
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_compile "$LINENO"
-then :
- tcl_cv_api_getgrnam_r_4=yes
-else case e in #(
- e) tcl_cv_api_getgrnam_r_4=no ;;
-esac
-fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;;
-esac
-fi
-{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_api_getgrnam_r_4" >&5
-printf "%s\n" "$tcl_cv_api_getgrnam_r_4" >&6; }
- tcl_ok=$tcl_cv_api_getgrnam_r_4
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRNAM_R_4 1" >>confdefs.h
-
- fi
- fi
- if test "$tcl_ok" = yes; then
-
-printf "%s\n" "#define HAVE_GETGRNAM_R 1" >>confdefs.h
-
- fi
-
-fi
-
-if test "`uname -s`" = "Darwin" && \
- test "`uname -r | awk -F. '{print $1}'`" -gt 5; then
- # Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
-
-printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
-
-
-printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
-
-
-elif test "`uname -s`" = "HP-UX" && \
- test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
- # Starting with HPUX 11.00 (we believe), gethostbyX
- # are actually MT-safe as they always return pointers
- # from TSD instead of static storage.
-
-printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
-
-
-printf "%s\n" "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
-
-
-else
-
- # Avoids picking hidden internal symbol from libc
- ac_fn_check_decl "$LINENO" "gethostbyname_r" "ac_cv_have_decl_gethostbyname_r" "#include