From d32d625787febc9c08fa7e1118df87ebfd4a9315 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 11:57:59 +0000 Subject: Travis CI build --- .travis.yml | 63 ++++++++++++++++++++++ README.md | 172 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 235 insertions(+) create mode 100644 .travis.yml create mode 100644 README.md diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..3abeb6b --- /dev/null +++ b/.travis.yml @@ -0,0 +1,63 @@ +dist: trusty +language: c +matrix: + include: + - os: linux + env: + - MATRIX_EVAL="BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-4.9 + env: + - MATRIX_EVAL="CC=gcc-4.9 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-5 + env: + - MATRIX_EVAL="CC=gcc-5 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-6 + env: + - MATRIX_EVAL="CC=gcc-6 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-7 + env: + - MATRIX_EVAL="CC=gcc-7 && BUILD_DIR=unix" + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="BUILD_DIR=unix" + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="BUILD_DIR=macosx" + - os: windows + env: + - MATRIX_EVAL="BUILD_DIR=win" + +before_install: + - eval "${MATRIX_EVAL}" + - cd ${BUILD_DIR} +install: + - ./configure +script: + - make + - make test diff --git a/README.md b/README.md new file mode 100644 index 0000000..db67791 --- /dev/null +++ b/README.md @@ -0,0 +1,172 @@ +README: Tcl +============ +This is the **Tcl 8.5.19** source distribution. + +You can get any source release of Tcl from [our distribution +site](https://sourceforge.net/projects/tcl/files/Tcl/). + +[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) + +Contents +-------- + 1. [Introduction](#intro) + 2. [Documentation](#doc) + 3. [Compiling and installing Tcl](#build) + 4. [Development tools](#devtools) + 5. [Tcl newsgroup](#complangtcl) + 6. [The Tcler's Wiki](#wiki) + 7. [Mailing lists](#email) + 8. [Support and Training](#support) + 9. [Tracking Development](#watch) + 10. [Thank You](#thanks) + +1. Introduction +--------------- +Tcl provides a powerful platform for creating integration applications that +tie together diverse applications, protocols, devices, and frameworks. +When paired with the Tk toolkit, Tcl provides the fastest and most powerful +way to create GUI applications that run on PCs, Unix, and Mac OS X. +Tcl can also be used for a variety of web-related tasks and for creating +powerful command languages for applications. + +Tcl is maintained, enhanced, and distributed freely by the Tcl community. +Source code development and tracking of bug reports and feature requests +takes place at [core.tcl-lang.org](https://core.tcl-lang.org/). +Tcl/Tk release and mailing list services are [hosted by +SourceForge](https://sourceforge.net/projects/tcl/) +with the Tcl Developer Xchange hosted at +[www.tcl-lang.org](https://www.tcl-lang.org). + +Tcl is a freely available open source package. You can do virtually +anything you like with it, such as modifying it, redistributing it, +and selling it either in whole or in part. See the file +`license.terms` for complete information. + +2. Documentation +---------------- + +Extensive documentation is available at our website. +The home page for this release, including new features, is +[here](https://www.tcl.tk/software/tcltk/8.5.html). +Detailed release notes can be found at the +[file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) +by clicking on the relevant version. + +Information about Tcl itself can be found at the [Developer +Xchange](https://www.tcl-lang.org/about/). +There have been many Tcl books on the market. Many are mentioned in +[the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). + +The complete set of reference manual entries for Tcl 8.5 is [online, +here](https://www.tcl-lang.org/man/tcl8.5/). + +2a. Unix Documentation +---------------------- + +The `doc` subdirectory in this release contains a complete set of +reference manual entries for Tcl. Files with extension "`.1`" are for +programs (for example, `tclsh.1`); files with extension "`.3`" are for C +library procedures; and files with extension "`.n`" describe Tcl +commands. The file "`doc/Tcl.n`" gives a quick summary of the Tcl +language syntax. To print any of the man pages on Unix, cd to the +"doc" directory and invoke your favorite variant of troff using the +normal -man macros, for example + + groff -man -Tpdf Tcl.n >output.pdf + +to print Tcl.n to PDF. If Tcl has been installed correctly and your "man" program +supports it, you should be able to access the Tcl manual entries using the +normal "man" mechanisms, such as + + man Tcl + +2b. Windows Documentation +------------------------- + +The "doc" subdirectory in this release contains a complete set of Windows +help files for Tcl. Once you install this Tcl release, a shortcut to the +Windows help Tcl documentation will appear in the "Start" menu: + + Start | Programs | Tcl | Tcl Help + +3. Compiling and installing Tcl +------------------------------- + +There are brief notes in the `unix/README`, `win/README`, and `macosx/README` +about compiling on these different platforms. There is additional information +about building Tcl from sources +[online](https://www.tcl-lang.org/doc/howto/compile.html). + +4. Development tools +--------------------------- + +ActiveState produces a high quality set of commercial quality development +tools that is available to accelerate your Tcl application development. +Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, +static code checker, single-file wrapping utility, bytecode compiler and +more. More information can be found at + + http://www.ActiveState.com/Tcl + +5. Tcl newsgroup +---------------- + +There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of +information about Tcl, Tk, and related applications. The newsgroup is a +great place to ask general information questions. For bug reports, please +see the "Support and bug fixes" section below. + +6. Tcl'ers Wiki +--------------- + +There is a [wiki-based open community site](https://wiki.tcl-lang.org/) +covering all aspects of Tcl/Tk. + +It is dedicated to the Tcl programming language and its extensions. A +wealth of useful information can be found there. It contains code +snippets, references to papers, books, and FAQs, as well as pointers to +development tools, extensions, and applications. You can also recommend +additional URLs by editing the wiki yourself. + +7. Mailing lists +---------------- + +Several mailing lists are hosted at SourceForge to discuss development or use +issues (like Macintosh and Windows topics). For more information and to +subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the +Mailing Lists page. + +8. Support and Training +------------------------ + +We are very interested in receiving bug reports, patches, and suggestions for +improvements. We prefer that you send this information to us as tickets +entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). + +We will log and follow-up on each bug, although we cannot promise a +specific turn-around time. Enhancements may take longer and may not happen +at all unless there is widespread support for them (we're trying to +slow the rate at which Tcl/Tk turns into a kitchen sink). It's very +difficult to make incompatible changes to Tcl/Tk at this point, due to +the size of the installed base. + +The Tcl community is too large for us to provide much individual support for +users. If you need help we suggest that you post questions to `comp.lang.tcl` +or ask a question on [Stack +Overflow](https://stackoverflow.com/questions/tagged/tcl). We read the +newsgroup and will attempt to answer esoteric questions for which no one else +is likely to know the answer. In addition, see the wiki for [links to other +organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. + +9. Tracking Development +----------------------- + +Tcl is developed in public. You can keep an eye on how Tcl is changing at +[core.tcl-lang.org](https://core.tcl-lang.org/). + +10. Thank You +------------- + +We'd like to express our thanks to the Tcl community for all the +helpful suggestions, bug reports, and patches we have received. +Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From ea29292705d5531747a472e71d3c59e9e9518f03 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 12:01:49 +0000 Subject: formatting fix --- README.md | 54 +++++++++++++++--------------------------------------- 1 file changed, 15 insertions(+), 39 deletions(-) diff --git a/README.md b/README.md index db67791..d5fe033 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -README: Tcl -============ +# README: Tcl + This is the **Tcl 8.5.19** source distribution. You can get any source release of Tcl from [our distribution @@ -7,8 +7,7 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) -Contents --------- +## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) @@ -20,8 +19,7 @@ Contents 9. [Tracking Development](#watch) 10. [Thank You](#thanks) -1. Introduction ---------------- +## 1. Introduction Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful @@ -42,9 +40,7 @@ anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. -2. Documentation ----------------- - +## 2. Documentation Extensive documentation is available at our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/8.5.html). @@ -60,9 +56,7 @@ There have been many Tcl books on the market. Many are mentioned in The complete set of reference manual entries for Tcl 8.5 is [online, here](https://www.tcl-lang.org/man/tcl8.5/). -2a. Unix Documentation ----------------------- - +### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C @@ -80,26 +74,20 @@ normal "man" mechanisms, such as man Tcl -2b. Windows Documentation -------------------------- - +### 2b. Windows Documentation The "doc" subdirectory in this release contains a complete set of Windows help files for Tcl. Once you install this Tcl release, a shortcut to the Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help -3. Compiling and installing Tcl -------------------------------- - +## 3. Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). -4. Development tools ---------------------------- - +## 4. Development tools ActiveState produces a high quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, @@ -108,17 +96,13 @@ more. More information can be found at http://www.ActiveState.com/Tcl -5. Tcl newsgroup ----------------- - +## 5. Tcl newsgroup There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. -6. Tcl'ers Wiki ---------------- - +## 6. Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. @@ -128,17 +112,13 @@ snippets, references to papers, books, and FAQs, as well as pointers to development tools, extensions, and applications. You can also recommend additional URLs by editing the wiki yourself. -7. Mailing lists ----------------- - +## 7. Mailing lists Several mailing lists are hosted at SourceForge to discuss development or use issues (like Macintosh and Windows topics). For more information and to subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the Mailing Lists page. -8. Support and Training ------------------------- - +## 8. Support and Training We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). @@ -158,15 +138,11 @@ newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the wiki for [links to other organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. -9. Tracking Development ------------------------ - +## 9. Tracking Development Tcl is developed in public. You can keep an eye on how Tcl is changing at [core.tcl-lang.org](https://core.tcl-lang.org/). -10. Thank You -------------- - +## 10. Thank You We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From e5cf3448bd80bc3f8d4b0441e759c17885c508fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 12:54:28 +0000 Subject: formatting tweak --- README.md | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index d5fe033..cbc49f0 100644 --- a/README.md +++ b/README.md @@ -8,18 +8,18 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. [Introduction](#intro) - 2. [Documentation](#doc) - 3. [Compiling and installing Tcl](#build) - 4. [Development tools](#devtools) - 5. [Tcl newsgroup](#complangtcl) - 6. [The Tcler's Wiki](#wiki) - 7. [Mailing lists](#email) - 8. [Support and Training](#support) - 9. [Tracking Development](#watch) - 10. [Thank You](#thanks) - -## 1. Introduction + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You + +## 1. Introduction Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful @@ -40,7 +40,7 @@ anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. -## 2. Documentation +## 2. Documentation Extensive documentation is available at our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/8.5.html). @@ -56,7 +56,7 @@ There have been many Tcl books on the market. Many are mentioned in The complete set of reference manual entries for Tcl 8.5 is [online, here](https://www.tcl-lang.org/man/tcl8.5/). -### 2a. Unix Documentation +### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C @@ -74,20 +74,20 @@ normal "man" mechanisms, such as man Tcl -### 2b. Windows Documentation +### 2b. Windows Documentation The "doc" subdirectory in this release contains a complete set of Windows help files for Tcl. Once you install this Tcl release, a shortcut to the Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help -## 3. Compiling and installing Tcl +## 3. Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). -## 4. Development tools +## 4. Development tools ActiveState produces a high quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, @@ -96,13 +96,13 @@ more. More information can be found at http://www.ActiveState.com/Tcl -## 5. Tcl newsgroup +## 5. Tcl newsgroup There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. -## 6. Tcl'ers Wiki +## 6. Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. @@ -112,13 +112,13 @@ snippets, references to papers, books, and FAQs, as well as pointers to development tools, extensions, and applications. You can also recommend additional URLs by editing the wiki yourself. -## 7. Mailing lists +## 7. Mailing lists Several mailing lists are hosted at SourceForge to discuss development or use issues (like Macintosh and Windows topics). For more information and to subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the Mailing Lists page. -## 8. Support and Training +## 8. Support and Training We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). @@ -138,11 +138,11 @@ newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the wiki for [links to other organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. -## 9. Tracking Development +## 9. Tracking Development Tcl is developed in public. You can keep an eye on how Tcl is changing at [core.tcl-lang.org](https://core.tcl-lang.org/). -## 10. Thank You +## 10. Thank You We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From 6efd8f71f2a7f42d036b4899461500a0ec69b1fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 16:44:51 +0000 Subject: formatting tweak --- README.md | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index cbc49f0..094a189 100644 --- a/README.md +++ b/README.md @@ -8,16 +8,16 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You ## 1. Introduction Tcl provides a powerful platform for creating integration applications that -- cgit v0.12 From 1caba8a761ad4d16139496bcbd931d91ed3931f7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 16:47:29 +0000 Subject: Add local links --- README.md | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 094a189..3c4440e 100644 --- a/README.md +++ b/README.md @@ -8,16 +8,16 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You + 1. [Introduction](#intro) + 2. [Documentation](#doc) + 3. [Compiling and installing Tcl](#build) + 4. [Development tools](#devtools) + 5. [Tcl newsgroup](#complangtcl) + 6. [The Tcler's Wiki](#wiki) + 7. [Mailing lists](#email) + 8. [Support and Training](#support) + 9. [Tracking Development](#watch) + 10. [Thank You](#thanks) ## 1. Introduction Tcl provides a powerful platform for creating integration applications that -- cgit v0.12 From 2e0a0b53053f3699f0593ca9e50b5ba45a548da1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 18:02:45 +0000 Subject: Remove old README --- README | 185 ----------------------------------------------------------------- 1 file changed, 185 deletions(-) delete mode 100644 README diff --git a/README b/README deleted file mode 100644 index c71d177..0000000 --- a/README +++ /dev/null @@ -1,185 +0,0 @@ -README: Tcl - This is the Tcl 8.5.19 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tcl from the URL above. - -Contents --------- - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You - -1. Introduction ---------------- -Tcl provides a powerful platform for creating integration applications that -tie together diverse applications, protocols, devices, and frameworks. -When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. -Tcl can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl.tk/ - -Tcl/Tk release and mailing list services are hosted by SourceForge: - - http://sourceforge.net/projects/tcl/ - -with the Tcl Developer Xchange hosted at: - - http://www.tcl.tk/ - -Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. Documentation ----------------- - -Extensive documentation is available at our website. -The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.5.html - -Detailed release notes can be found at the file distributions page -by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/Tcl/ - -Information about Tcl itself can be found at - http://www.tcl.tk/about/ - -There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 - -To view the complete set of reference manual entries for Tcl 8.5 online, -visit the URL: - http://www.tcl.tk/man/tcl8.5/ - -2a. Unix Documentation ----------------------- - -The "doc" subdirectory in this release contains a complete set of -reference manual entries for Tcl. Files with extension ".1" are for -programs (for example, tclsh.1); files with extension ".3" are for C -library procedures; and files with extension ".n" describe Tcl -commands. The file "doc/Tcl.n" gives a quick summary of the Tcl -language syntax. To print any of the man pages on Unix, cd to the -"doc" directory and invoke your favorite variant of troff using the -normal -man macros, for example - - ditroff -man Tcl.n - -to print Tcl.n. If Tcl has been installed correctly and your "man" program -supports it, you should be able to access the Tcl manual entries using the -normal "man" mechanisms, such as - - man Tcl - -2b. Windows Documentation -------------------------- - -The "doc" subdirectory in this release contains a complete set of Windows -help files for Tcl. Once you install this Tcl release, a shortcut to the -Windows help Tcl documentation will appear in the "Start" menu: - - Start | Programs | Tcl | Tcl Help - -3. Compiling and installing Tcl -------------------------------- - -There are brief notes in the unix/README, win/README, and macosx/README about -compiling on these different platforms. There is additional information -about building Tcl from sources at - - http://www.tcl.tk/doc/howto/compile.html - -4. Development tools ---------------------------- - -ActiveState produces a high quality set of commercial quality development -tools that is available to accelerate your Tcl application development. -Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, -static code checker, single-file wrapping utility, bytecode compiler and -more. More information can be found at - - http://www.ActiveState.com/Tcl - -5. Tcl newsgroup ----------------- - -There is a USENET news group, "comp.lang.tcl", intended for the exchange of -information about Tcl, Tk, and related applications. The newsgroup is a -great place to ask general information questions. For bug reports, please -see the "Support and bug fixes" section below. - -6. Tcl'ers Wiki ---------------- - -A Wiki-based open community site covering all aspects of Tcl/Tk is at: - - http://wiki.tcl.tk/ - -It is dedicated to the Tcl programming language and its extensions. A -wealth of useful information can be found there. It contains code -snippets, references to papers, books, and FAQs, as well as pointers to -development tools, extensions, and applications. You can also recommend -additional URLs by editing the wiki yourself. - -7. Mailing lists ----------------- - -Several mailing lists are hosted at SourceForge to discuss development or -use issues (like Macintosh and Windows topics). For more information and -to subscribe, visit: - - http://sourceforge.net/projects/tcl/ - -and go to the Mailing Lists page. - -8. Support and Training ------------------------- - -We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us as -tickets entered into our tracker at: - - http://core.tcl.tk/tcl/reportlist - -We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements may take longer and may not happen -at all unless there is widespread support for them (we're trying to -slow the rate at which Tcl/Tk turns into a kitchen sink). It's very -difficult to make incompatible changes to Tcl/Tk at this point, due to -the size of the installed base. - -The Tcl community is too large for us to provide much individual support -for users. If you need help we suggest that you post questions to -comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric -questions for which no one else is likely to know the answer. In addition, -see the following Web site for links to other organizations that offer -Tcl/Tk training: - - http://wiki.tcl.tk/training - -9. Tracking Development ------------------------ - -Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ - -10. Thank You -------------- - -We'd like to express our thanks to the Tcl community for all the -helpful suggestions, bug reports, and patches we have received. -Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From 0c78f5bbada0703c8063287e2e063604c4023ba7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 10:16:05 +0000 Subject: Disable windows builds. Make test failures fatal. --- .travis.yml | 12 +++++++----- library/tcltest/tcltest.tcl | 4 ++-- tests/all.tcl | 4 +++- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3abeb6b..d5c93c1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -48,16 +48,18 @@ matrix: - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=macosx" - - os: windows - env: - - MATRIX_EVAL="BUILD_DIR=win" + - MATRIX_EVAL="BUILD_DIR=macosx && NO_DIRECT_CONFIGURE=1" +### C builds not currently supported on Windows instances +# - os: windows +# env: +# - MATRIX_EVAL="BUILD_DIR=win" before_install: - eval "${MATRIX_EVAL}" + - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - - ./configure + - test -z "$NO_DIRECT_CONFIGURE" || ./configure script: - make - make test diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8e43859..0d55ff7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2696,7 +2696,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2842,7 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index d01a54d..f3463c6 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,4 +14,6 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} -- cgit v0.12 From 8c05c20df453400c69cdcddd621fd9fc7e692e73 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 05:56:37 +0000 Subject: Implement TIP 522, Test error codes with Tcltest --- library/tcltest/tcltest.tcl | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f1b6082..a4954e7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1901,7 +1904,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1912,7 +1915,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1944,6 +1947,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1976,7 +1983,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] @@ -2003,7 +2010,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2012,6 +2019,13 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + $errorCode ne "" && \ + ![string match $errorCode $errorCodeRes(body)]} { + set codeFailure 1 + set errCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2055,7 +2069,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2159,7 +2173,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2171,7 +2185,11 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } - if {$codeFailure} { + if {$errCodeFailure} { + # TODO + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } elseif {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } 1 { set msg "Test generated error" } @@ -2186,7 +2204,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2212,7 +2230,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { -- cgit v0.12 From c201290179fd33b699c27e7ed181281c18a8fa06 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 22 Oct 2018 13:11:45 +0000 Subject: Expand the build matrix --- .travis.yml | 44 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index d5c93c1..0f8af5a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,11 +1,26 @@ dist: trusty +sudo: false language: c matrix: include: - os: linux + compiler: clang env: - - MATRIX_EVAL="BUILD_DIR=unix" + - MATRIX_EVAL="" BUILD_DIR=unix - os: linux + compiler: clang + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc addons: apt: sources: @@ -13,8 +28,9 @@ matrix: packages: - g++-4.9 env: - - MATRIX_EVAL="CC=gcc-4.9 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-4.9" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -22,8 +38,9 @@ matrix: packages: - g++-5 env: - - MATRIX_EVAL="CC=gcc-5 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-5" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -31,8 +48,9 @@ matrix: packages: - g++-6 env: - - MATRIX_EVAL="CC=gcc-6 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-6" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -40,26 +58,34 @@ matrix: packages: - g++-7 env: - - MATRIX_EVAL="CC=gcc-7 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-7" BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=unix" + - MATRIX_EVAL="" BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=macosx && NO_DIRECT_CONFIGURE=1" + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode9 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode10 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 ### C builds not currently supported on Windows instances # - os: windows # env: -# - MATRIX_EVAL="BUILD_DIR=win" +# - MATRIX_EVAL="" BUILD_DIR=win before_install: - eval "${MATRIX_EVAL}" - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - - test -z "$NO_DIRECT_CONFIGURE" || ./configure + - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - make test -- cgit v0.12 From 5b1614f31a3c2c510c726089b6ca499cfb792e72 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 20:27:03 +0000 Subject: Documentation and revision bump for tip 522 --- doc/tcltest.n | 14 ++++++++++++-- library/init.tcl | 2 +- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 10 ++++++---- unix/Makefile.in | 4 ++-- 5 files changed, 22 insertions(+), 10 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 05c1922..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,7 +16,7 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest\fR ?\fB2.3\fR? +\fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR @@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized: ?\fB\-output \fIexpectedOutput\fR? ?\fB\-errorOutput \fIexpectedError\fR? ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? ?\fB\-match \fImode\fR? .CE .PP @@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and diff --git a/library/init.tcl b/library/init.tcl index 51339d0..1221e61 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -810,7 +810,7 @@ foreach {safe package version file} { 1 opt 0.4.7 {opt optparse.tcl} 0 platform 1.0.14 {platform platform.tcl} 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.4.1 {tcltest tcltest.tcl} + 1 tcltest 2.5.0 {tcltest tcltest.tcl} } { if {$isafe && !$safe} continue package ifneeded $package $version [list source [file join $dir {*}$file]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index eadb1bd..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index a4954e7..8b14142 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1842,7 +1842,7 @@ proc tcltest::SubstArguments {argList} { # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. # errorCode - Expected error code. This attribute is -# optional; default is {}. It is a glob pattern. +# optional; default is {*}. It is a glob pattern. # If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. @@ -1895,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1948,7 +1951,7 @@ proc tcltest::test {name description args} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } # errorCode without returnCode 1 is meaningless - if {$errorCode ne "" && 1 ni $returnCodes} { + if {$errorCode ne "*" && 1 ni $returnCodes} { set returnCodes 1 } } else { @@ -2021,7 +2024,6 @@ proc tcltest::test {name description args} { } set errCodeFailure 0 if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ - $errorCode ne "" && \ ![string match $errorCode $errorCodeRes(body)]} { set codeFailure 1 set errCodeFailure 1 diff --git a/unix/Makefile.in b/unix/Makefile.in index 487ae61..c42abbf 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -933,9 +933,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.7.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm - @echo "Installing package tcltest 2.4.1 as a Tcl Module" + @echo "Installing package tcltest 2.5.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm + "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm @echo "Installing package platform 1.0.14 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm -- cgit v0.12 From 394e22ef5d4e279dbb1e8d2d6616c84e70f5032f Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 21:15:00 +0000 Subject: Updated tests to exercise new feature. --- tests/assemble.test | 11 ++++++----- tests/dict.test | 12 ++---------- tests/ioCmd.test | 4 ++-- tests/source.test | 7 +++---- tests/tcltest.test | 6 +++--- 5 files changed, 16 insertions(+), 24 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index d7c47a9..bea780a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -852,10 +852,11 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { @@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} { } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr diff --git a/tests/dict.test b/tests/dict.test index a6b0cb4..1479727 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} { } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -returnCodes error -result {missing value to go with key} -test dict-4.13a {dict replace command: type check is mandatory} { - catch {dict replace { a b c d e }} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} @@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} { } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in dict} -test dict-4.17a {dict replace command: type check is mandatory} { - catch {dict replace " a b \{c d "} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY BRACE} +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 948671e..3c4caa7 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -154,10 +154,10 @@ test iocmd-4.11 {read command} { test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek diff --git a/tests/source.test b/tests/source.test index 0235bd1..ab6b447 100644 --- a/tests/source.test +++ b/tests/source.test @@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { diff --git a/tests/tcltest.test b/tests/tcltest.test index 1487865..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ -- cgit v0.12 From bf9af9a40854d7116b0d6a17fae0594ce3c38f09 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Tue, 23 Oct 2018 21:06:30 +0000 Subject: Cleanup --- library/tcltest/tcltest.tcl | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8b14142..c90d726 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2022,11 +2022,10 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } - set errCodeFailure 0 + set errorCodeFailure 0 if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ ![string match $errorCode $errorCodeRes(body)]} { - set codeFailure 1 - set errCodeFailure 1 + set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare @@ -2122,7 +2121,7 @@ proc tcltest::test {name description args} { variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2187,11 +2186,11 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } - if {$errCodeFailure} { - # TODO + if {$errorCodeFailure} { puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" puts [outputChannel] "---- Error code should have been: '$errorCode'" - } elseif {$codeFailure} { + } + if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } 1 { set msg "Test generated error" } -- cgit v0.12 From f44fb9b4500e047fdb9e361a17f44fa46dffec2b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Oct 2018 14:33:54 +0000 Subject: Request the tcltest version that provides the testing facilities used. --- tests/assemble.test | 2 +- tests/dict.test | 2 +- tests/ioCmd.test | 2 +- tests/source.test | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index bea780a..05c1f9b 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -12,7 +12,7 @@ # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} diff --git a/tests/dict.test b/tests/dict.test index 1479727..904ec53 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 3c4caa7..68bc542 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/source.test b/tests/source.test index ab6b447..8b146d3 100644 --- a/tests/source.test +++ b/tests/source.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } -- cgit v0.12 From c69ccc749e9de9c32a0e0c7b6f733b8e64e1209f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Oct 2018 21:22:18 +0000 Subject: Backport "registry" version 1.3.3, so all active branches now have the same registry version. (this commit must -eventually- be merge-marked to core-8-6-branch, since everything is there already) --- library/reg/pkgIndex.tcl | 8 +- tests/registry.test | 294 +++++++++++++-------- win/Makefile.in | 6 +- win/configure.in | 4 +- win/makefile.bc | 4 +- win/makefile.vc | 10 +- win/rules.vc | 4 +- win/tclWinReg.c | 666 +++++++++++++++++++++++------------------------ 8 files changed, 519 insertions(+), 477 deletions(-) diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 1241f2a..12c7ea5 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12g.dll] registry] + package ifneeded registry 1.3.3 \ + [list load [file join $dir tclreg13g.dll] registry] } else { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12.dll] registry] + package ifneeded registry 1.3.3 \ + [list load [file join $dir tclreg13.dll] registry] } diff --git a/tests/registry.test b/tests/registry.test index cbca4fd..539ba2d 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - package require registry + set ::regver [package require registry 1.3.3] }]} { testConstraint reg 1 } @@ -30,17 +30,35 @@ testConstraint english [expr { [llength [info commands testlocale]] && [string match "English*" [testlocale all ""]] }] - + +test registry-1.0 {check if we are testing the right dll} {win reg} { + set ::regver +} {1.3.3} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg -} {1 {wrong # args: should be "registry option ?arg arg ...?"}} +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} +test registry-1.1a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit} msg] $msg +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} +test registry-1.1b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit} msg] $msg +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} test registry-1.2 {argument parsing for registry command} {win reg} { list [catch {registry foo} msg] $msg } {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}} +test registry-1.2a {argument parsing for registry command} {win reg} { + list [catch {registry -33bit foo} msg] $msg +} {1 {bad mode "-33bit": must be -32bit or -64bit}} test registry-1.3 {argument parsing for registry command} {win reg} { list [catch {registry d} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} +test registry-1.3a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit d} msg] $msg +} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}} +test registry-1.3b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit d} msg] $msg +} {1 {wrong # args: should be "registry -64bit delete keyName ?valueName?"}} test registry-1.4 {argument parsing for registry command} {win reg} { list [catch {registry delete} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} @@ -51,6 +69,12 @@ test registry-1.5 {argument parsing for registry command} {win reg} { test registry-1.6 {argument parsing for registry command} {win reg} { list [catch {registry g} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.6a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit g} msg] $msg +} {1 {wrong # args: should be "registry -32bit get keyName valueName"}} +test registry-1.6b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit g} msg] $msg +} {1 {wrong # args: should be "registry -64bit get keyName valueName"}} test registry-1.7 {argument parsing for registry command} {win reg} { list [catch {registry get} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} @@ -64,6 +88,12 @@ test registry-1.9 {argument parsing for registry command} {win reg} { test registry-1.10 {argument parsing for registry command} {win reg} { list [catch {registry k} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} +test registry-1.10a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit k} msg] $msg +} {1 {wrong # args: should be "registry -32bit keys keyName ?pattern?"}} +test registry-1.10b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit k} msg] $msg +} {1 {wrong # args: should be "registry -64bit keys keyName ?pattern?"}} test registry-1.11 {argument parsing for registry command} {win reg} { list [catch {registry keys} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} @@ -74,6 +104,12 @@ test registry-1.12 {argument parsing for registry command} {win reg} { test registry-1.13 {argument parsing for registry command} {win reg} { list [catch {registry s} msg] $msg } {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.13a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit s} msg] $msg +} {1 {wrong # args: should be "registry -32bit set keyName ?valueName data ?type??"}} +test registry-1.13b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit s} msg] $msg +} {1 {wrong # args: should be "registry -64bit set keyName ?valueName data ?type??"}} test registry-1.14 {argument parsing for registry command} {win reg} { list [catch {registry set} msg] $msg } {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} @@ -87,6 +123,12 @@ test registry-1.16 {argument parsing for registry command} {win reg} { test registry-1.17 {argument parsing for registry command} {win reg} { list [catch {registry t} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.17a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit t} msg] $msg +} {1 {wrong # args: should be "registry -32bit type keyName valueName"}} +test registry-1.17b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit t} msg] $msg +} {1 {wrong # args: should be "registry -64bit type keyName valueName"}} test registry-1.18 {argument parsing for registry command} {win reg} { list [catch {registry type} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} @@ -100,6 +142,12 @@ test registry-1.20 {argument parsing for registry command} {win reg} { test registry-1.21 {argument parsing for registry command} {win reg} { list [catch {registry v} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} +test registry-1.21a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit v} msg] $msg +} {1 {wrong # args: should be "registry -32bit values keyName ?pattern?"}} +test registry-1.21b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit v} msg] $msg +} {1 {wrong # args: should be "registry -64bit values keyName ?pattern?"}} test registry-1.22 {argument parsing for registry command} {win reg} { list [catch {registry values} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} @@ -111,10 +159,10 @@ test registry-2.1 {DeleteKey: bad key} {win reg} { list [catch {registry delete foo} msg] $msg } {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-2.2 {DeleteKey: bad key} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER} msg] $msg + list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg } {1 {bad key: cannot delete root keys}} test registry-2.3 {DeleteKey: bad key} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg } {1 {bad key: cannot delete root keys}} test registry-2.4 {DeleteKey: subkey at root level} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar @@ -235,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -439,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -457,161 +505,181 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { - registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 199] [string repeat x 199] multi_sz - set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 199]] +test registry-6.21 {GetValue: very long value names and values} {win reg} { + registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz + set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar set result -} [string repeat x 199] +} [string repeat x 16383] -test registry-7.1 {GetValueNames: bad key} {win reg english} { +test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar - list [catch {registry values HKEY_CURRENT_USER\\TclFoobar} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} -test registry-7.2 {GetValueNames} {win reg} { +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -returnCodes error -result {unable to open key: The system cannot find the file specified.} +test registry-7.2 {GetValueNames} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar - set result [registry values HKEY_CURRENT_USER\\TclFoobar] +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} baz -test registry-7.3 {GetValueNames} {win reg} { +} -result baz +test registry-7.3 {GetValueNames} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar {} foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {{} baz blat} -test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} { +} -result {{} baz blat} +test registry-7.4 {GetValueNames: remote key} -constraints {win reg nonPortable english} -body { set hostname [info hostname] registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar] registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar set result -} baz -test registry-7.5 {GetValueNames: empty key} {win reg} { +} -result baz +test registry-7.5 {GetValueNames: empty key} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar - set result [registry values HKEY_CURRENT_USER\\TclFoobar] +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {} -test registry-7.6 {GetValueNames: patterns} {win reg} { +} -result {} +test registry-7.6 {GetValueNames: patterns} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {baz blat} -test registry-7.7 {GetValueNames: names with spaces} {win reg} { +} -result {baz blat} +test registry-7.7 {GetValueNames: names with spaces} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz\ bar foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {{baz bar} blat} +} -result {{baz bar} blat} -test registry-8.1 {OpenSubKey} {win reg nonPortable english} { - # This test will only succeed if the current user does not have registry - # access on the specified machine. - list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg -} {1 {unable to open key: Access is denied.}} -test registry-8.2 {OpenSubKey} {win reg} { +test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \ + -body { + # This test will only succeed if the current user does not have + # registry access on the specified machine. + registry keys {\\mom\HKEY_LOCAL_MACHINE} + } -returnCodes error -result "unable to open key: Access is denied." +test registry-8.2 {OpenSubKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar - set result [registry keys HKEY_CURRENT_USER TclFoobar] +} -body { + registry keys HKEY_CURRENT_USER TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} TclFoobar -test registry-8.3 {OpenSubKey} {win reg english} { +} -result {TclFoobar} +test registry-8.3 {OpenSubKey} -constraints {win reg english} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar - list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} +} -body { + registry keys HKEY_CURRENT_USER\\TclFoobar +} -returnCodes error \ + -result "unable to open key: The system cannot find the file specified." -test registry-9.1 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\} msg] $msg -} "1 {bad key \"\\\": must start with a valid root}" -test registry-9.2 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\foobar} msg] $msg -} {1 {bad key "\foobar": must start with a valid root}} -test registry-9.3 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.4 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\\\} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.5 {ParseKeyName: bad keys} {win reg english nt} { - list [catch {registry values \\\\\\HKEY_CURRENT_USER} msg] $msg -} {1 {unable to open key: The network address is invalid.}} -test registry-9.6 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\gaspode} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.7 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values foobar} msg] $msg -} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.8 {ParseKeyName: null keys} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg -} {1 {bad key: cannot delete root keys}} -test registry-9.9 {ParseKeyName: null keys} {win reg english} { - list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar\\baz} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} +test registry-9.1 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\ +} -returnCodes error -result "bad key \"\\\": must start with a valid root" +test registry-9.2 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\foobar +} -returnCodes error -result {bad key "\foobar": must start with a valid root} +test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\ +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\\\ +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { + registry values \\\\\\HKEY_CLASSES_ROOT +} -returnCodes error -result {unable to open key: The network address is invalid.} +test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\gaspode +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.7 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values foobar +} -returnCodes error -result {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.8 {ParseKeyName: null keys} -constraints {win reg} -body { + registry delete HKEY_CLASSES_ROOT\\ +} -returnCodes error -result {bad key: cannot delete root keys} +test registry-9.9 {ParseKeyName: null keys} \ + -constraints {win reg english} \ + -body {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} \ + -returnCodes error \ + -result {unable to open key: The system cannot find the file specified.} -test registry-10.1 {RecursiveDeleteKey} {win reg} { +test registry-10.1 {RecursiveDeleteKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar +} -body { registry set HKEY_CURRENT_USER\\TclFoobar\\test1 registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3 registry delete HKEY_CURRENT_USER\\TclFoobar set result [registry keys HKEY_CURRENT_USER TclFoobar] set result -} {} -test registry-10.2 {RecursiveDeleteKey} {win reg} { +} -result {} +test registry-10.2 {RecursiveDeleteKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\test1 registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3 - set result [registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4] +} -body { + registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4 +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {} - -test registry-11.1 {SetValue: recursive creation} {win reg} { - registry delete HKEY_CURRENT_USER\\TclFoobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar - set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] -} foobar -test registry-11.2 {SetValue: modification} {win reg} { - registry delete HKEY_CURRENT_USER\\TclFoobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob - set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] -} frob -test registry-11.3 {SetValue: failure} {win reg nonPortable english} { - # This test will only succeed if the current user does not have registry - # access on the specified machine. - list [catch {registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar} msg] $msg -} {1 {unable to open key: Access is denied.}} +} -result {} -test registry-12.1 {BroadcastValue} {win reg} { - list [catch {registry broadcast} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.2 {BroadcastValue} {win reg} { - list [catch {registry broadcast "" -time} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.3 {BroadcastValue} {win reg} { - list [catch {registry broadcast "" - 500} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.4 {BroadcastValue} {win reg} { - list [catch {registry broadcast {Environment}} msg] $msg -} {0 {1 0}} -test registry-12.5 {BroadcastValue} {win reg} { - list [catch {registry b {}} msg] $msg -} {0 {1 0}} +test registry-11.1 {SetValue: recursive creation} \ + -constraints {win reg} -setup { + registry delete HKEY_CURRENT_USER\\TclFoobar + } -body { + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar + set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] + } -result {foobar} +test registry-11.2 {SetValue: modification} -constraints {win reg} \ + -setup { + registry delete HKEY_CURRENT_USER\\TclFoobar + } -body { + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob + set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] + } -result {frob} +test registry-11.3 {SetValue: failure} \ + -constraints {win reg nonPortable english} \ + -body { + # This test will only succeed if the current user does not have + # registry access on the specified machine. + registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar + } -returnCodes error -result {unable to open key: Access is denied.} +test registry-12.1 {BroadcastValue} -constraints {win reg} -body { + registry broadcast +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.2 {BroadcastValue} -constraints {win reg} -body { + registry broadcast "" -time +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.3 {BroadcastValue} -constraints {win reg} -body { + registry broadcast "" - 500 +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.4 {BroadcastValue} -constraints {win reg} -body { + registry broadcast {Environment} +} -result {1 0} +test registry-12.5 {BroadcastValue} -constraints {win reg} -body { + registry b {} +} -result {1 0} + # cleanup ::tcltest::cleanupTests return diff --git a/win/Makefile.in b/win/Makefile.in index d9b52fa..6d1ce95 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -495,7 +495,7 @@ tclAppInit.${OBJEXT} : tclAppInit.c # The following objects should be built using the stub interfaces tclWinReg.${OBJEXT} : tclWinReg.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) tclWinDde.${OBJEXT} : tclWinDde.c $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) @@ -710,13 +710,13 @@ test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) + package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tcltest with the proper path,... runtest: binaries $(TCLTEST) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` diff --git a/win/configure.in b/win/configure.in index 8931a38..fa75e5b 100644 --- a/win/configure.in +++ b/win/configure.in @@ -22,9 +22,9 @@ TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.2 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=2 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/makefile.bc b/win/makefile.bc index 6421682..20d89bc 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -130,8 +130,8 @@ VERSION = 85 DDEVERSION = 13 DDEDOTVERSION = 1.3 -REGVERSION = 12 -REGDOTVERSION = 1.2 +REGVERSION = 13 +REGDOTVERSION = 1.3 BINROOT = .. !IF "$(NODEBUG)" == "1" diff --git a/win/makefile.vc b/win/makefile.vc index aedb7a6..c330fcd 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -185,7 +185,7 @@ VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) DDEDOTVERSION = 1.3 DDEVERSION = $(DDEDOTVERSION:.=) -REGDOTVERSION = 1.2 +REGDOTVERSION = 1.3 REGVERSION = $(REGDOTVERSION:.=) BINROOT = . @@ -539,13 +539,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif @@ -885,9 +885,9 @@ $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c !if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $? !else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $? !endif diff --git a/win/rules.vc b/win/rules.vc index 2edaa49..0ae0e8e 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -590,7 +590,7 @@ TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe" TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib -TCLREGLIB = "$(_TCLDIR)\lib\tclreg12$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target @@ -603,7 +603,7 @@ TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe" TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library -TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools diff --git a/win/tclWinReg.c b/win/tclWinReg.c index a6ce2ce..f3d7a07 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -12,36 +12,41 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" -#include "tclPort.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include /* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Registry_Init declaration is in the source file itself, which is only - * accessed when we are building a library. + * Ensure that we can say which registry is being accessed. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT +#ifndef KEY_WOW64_64KEY +# define KEY_WOW64_64KEY (0x0100) +#endif +#ifndef KEY_WOW64_32KEY +# define KEY_WOW64_32KEY (0x0200) +#endif /* * The maximum length of a sub-key name. */ #ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 +# define MAX_KEY_LENGTH 256 #endif /* * The following macros convert between different endian ints. */ -#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) -#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) +#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) +#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* * The following flag is used in OpenKeys to indicate that the specified key @@ -55,7 +60,7 @@ * system predefined keys. */ -static CONST char *rootKeyNames[] = { +static const char *const rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL @@ -66,7 +71,7 @@ static const HKEY rootKeys[] = { HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA }; -static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; +static const char REGISTRY_ASSOC_KEY[] = "registry::command"; /* * The following table maps from registry types to strings. Note that the @@ -74,7 +79,7 @@ static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; * types so we don't need a separate table to hold the mapping. */ -static CONST char *typeNames[] = { +static const char *const typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; @@ -82,100 +87,26 @@ static CONST char *typeNames[] = { static DWORD lastType = REG_RESOURCE_LIST; /* - * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside of - * the current code page. - */ - -typedef struct RegWinProcs { - int useWide; - - LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); - LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); - LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); - LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *); - LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *); - LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *); - LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *); - LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD); -} RegWinProcs; - -static RegWinProcs *regWinProcs; - -static RegWinProcs asciiProcs = { - 0, - - (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExA, -}; - -static RegWinProcs unicodeProcs = { - 1, - - (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExW, -}; - - -/* * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, - Tcl_Obj * CONST objv[]); + Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(ClientData clientData); -static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode, int flags, HKEY *keyPtr); static DWORD OpenSubKey(char *hostName, HKEY rootKey, @@ -185,16 +116,16 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - CONST TCHAR * pKeyName); + const TCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj * CONST objv[]); + Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, - Tcl_Obj *typeObj); + Tcl_Obj *typeObj, REGSAM mode); -EXTERN int Registry_Init(Tcl_Interp *interp); -EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); +DLLEXPORT int Registry_Init(Tcl_Interp *interp); +DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- @@ -218,25 +149,14 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } - /* - * Determine if the unicode interfaces are available and select the - * appropriate registry function table. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - regWinProcs = &unicodeProcs; - } else { - regWinProcs = &asciiProcs; - } - cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, - (ClientData)interp, DeleteCmd); - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd); - return Tcl_PkgProvide(interp, "registry", "1.2.2"); + interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); + return Tcl_PkgProvide(interp, "registry", "1.3.3"); } /* @@ -276,7 +196,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -306,7 +226,8 @@ DeleteCmd( ClientData clientData) { Tcl_Interp *interp = clientData; - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL); + + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } /* @@ -330,89 +251,125 @@ RegistryObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj * CONST objv[]) /* Argument values. */ + Tcl_Obj *const objv[]) /* Argument values. */ { - int index; - char *errString = NULL; + int n = 1; + int index, argc; + REGSAM mode = 0; + const char *errString = NULL; - static CONST char *subcommands[] = { + static const char *const subcommands[] = { "broadcast", "delete", "get", "keys", "set", "type", "values", NULL }; enum SubCmdIdx { BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; + static const char *const modes[] = { + "-32bit", "-64bit", NULL + }; if (objc < 2) { - Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); + wrongArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetString(objv[n])[0] == '-') { + if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -32bit */ + mode |= KEY_WOW64_32KEY; + break; + case 1: /* -64bit */ + mode |= KEY_WOW64_64KEY; + break; + } + if (objc < 3) { + goto wrongArgs; + } + } + + if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } + argc = (objc - n); switch (index) { case BroadcastIdx: /* broadcast */ - return BroadcastValue(interp, objc, objv); + if (argc == 1 || argc == 3) { + int res = BroadcastValue(interp, argc, objv + n); + + if (res != TCL_BREAK) { + return res; + } + } + errString = "keyName ?-timeout milliseconds?"; break; case DeleteIdx: /* delete */ - if (objc == 3) { - return DeleteKey(interp, objv[2]); - } else if (objc == 4) { - return DeleteValue(interp, objv[2], objv[3]); + if (argc == 1) { + return DeleteKey(interp, objv[n], mode); + } else if (argc == 2) { + return DeleteValue(interp, objv[n], objv[n+1], mode); } errString = "keyName ?valueName?"; break; case GetIdx: /* get */ - if (objc == 4) { - return GetValue(interp, objv[2], objv[3]); + if (argc == 2) { + return GetValue(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case KeysIdx: /* keys */ - if (objc == 3) { - return GetKeyNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetKeyNames(interp, objv[2], objv[3]); + if (argc == 1) { + return GetKeyNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetKeyNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; case SetIdx: /* set */ - if (objc == 3) { + if (argc == 1) { HKEY key; /* * Create the key and then close it immediately. */ - if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { return TCL_ERROR; } RegCloseKey(key); return TCL_OK; - } else if (objc == 5 || objc == 6) { - Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; - return SetValue(interp, objv[2], objv[3], objv[4], typeObj); + } else if (argc == 3) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL, + mode); + } else if (argc == 4) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3], + mode); } errString = "keyName ?valueName data ?type??"; break; case TypeIdx: /* type */ - if (objc == 4) { - return GetType(interp, objv[2], objv[3]); + if (argc == 2) { + return GetType(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case ValuesIdx: /* values */ - if (objc == 3) { - return GetValueNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetValueNames(interp, objv[2], objv[3]); + if (argc == 1) { + return GetValueNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetValueNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; } - Tcl_WrongNumArgs(interp, 2, objv, errString); + Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString); return TCL_ERROR; } @@ -435,33 +392,35 @@ RegistryObjCmd( static int DeleteKey( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj) /* Name of key to delete. */ + Tcl_Obj *keyNameObj, /* Name of key to delete. */ + REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - CONST char *nativeTail; + const TCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; - int length; Tcl_DString buf; + REGSAM saveMode = mode; /* * Find the parent of the key being deleted and open it. */ - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc((unsigned int) length + 1); + keyName = Tcl_GetString(keyNameObj); + buffer = Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) != TCL_OK) { - ckfree(buffer); + Tcl_Free(buffer); return TCL_ERROR; } if (*keyName == '\0') { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad key: cannot delete root keys", -1)); - ckfree(buffer); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); + Tcl_Free(buffer); return TCL_ERROR; } @@ -473,15 +432,15 @@ DeleteKey( keyName = NULL; } - result = OpenSubKey(hostName, rootKey, keyName, - KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; + result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); if (result != ERROR_SUCCESS) { - ckfree(buffer); + Tcl_Free(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to delete key: ", -1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -491,7 +450,7 @@ DeleteKey( */ nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); - result = RecursiveDeleteKey(subkey, nativeTail); + result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { @@ -504,7 +463,7 @@ DeleteKey( } RegCloseKey(subkey); - ckfree(buffer); + Tcl_Free(buffer); return result; } @@ -528,11 +487,12 @@ static int DeleteValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to delete. */ + Tcl_Obj *valueNameObj, /* Name of value to delete. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; char *valueName; - int length; + size_t length; DWORD result; Tcl_DString ds; @@ -540,19 +500,20 @@ DeleteValue( * Attempt to open the key for deletion. */ - if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_SET_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); + result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -585,11 +546,13 @@ static int GetKeyNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { - char *pattern; /* Pattern being matched against subkeys */ + const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH*2]; /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -603,40 +566,37 @@ GetKeyNames( pattern = NULL; } - /* Attempt to open the key for enumeration. */ + /* + * Attempt to open the key for enumeration. + */ - if (OpenKey(interp, keyNameObj, - KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS, - 0, &key) != TCL_OK) { + mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - /* Enumerate the subkeys */ + /* + * Enumerate the subkeys. + */ resultPtr = Tcl_NewObj(); for (index = 0;; ++index) { bufSize = MAX_KEY_LENGTH; - result = (*regWinProcs->regEnumKeyExProc) - (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); + result = RegEnumKeyEx(key, index, buffer, &bufSize, + NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, - "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } break; } - if (regWinProcs->useWide) { - Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds); - } else { - Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds); - } - name = Tcl_DStringValue(&ds); + name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; @@ -679,22 +639,22 @@ static int GetType( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - DWORD result; - DWORD type; + DWORD result, type; Tcl_DString ds; - char *valueName; - CONST char *nativeValue; - int length; + const char *valueName; + const TCHAR *nativeValue; + size_t length; /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -702,17 +662,18 @@ GetType( * Get the type of the value. */ - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, + result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -751,20 +712,22 @@ static int GetValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - char *valueName; - CONST char *nativeValue; + const char *valueName; + const TCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; - int nameLen; + size_t nameLen; /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -780,12 +743,13 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; - valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); + valueName = Tcl_GetString(valueNameObj); + nameLen = valueNameObj->length; nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); - result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, + result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* @@ -794,17 +758,17 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2); - Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1)); - result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, + length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -819,7 +783,7 @@ GetValue( if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, - *((DWORD*) Tcl_DStringValue(&data))))); + *((DWORD *) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); char *end = Tcl_DStringValue(&data) + length; @@ -831,19 +795,17 @@ GetValue( * we get bogus data. */ - while (p < end && ((regWinProcs->useWide) - ? *((Tcl_UniChar *)p) : *p) != 0) { + while ((p < end) && *((WCHAR *) p) != 0) { + WCHAR *wp; + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - if (regWinProcs->useWide) { - Tcl_UniChar* up = (Tcl_UniChar*) p; - while (*up++ != 0) {} - p = (char*) up; - } else { - while (*p++ != '\0') {} - } + wp = (WCHAR *) p; + + while (*wp++ != 0) {/* empty body */} + p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -885,27 +847,27 @@ static int GetValueNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; Tcl_Obj *resultPtr; DWORD index, size, result; Tcl_DString buffer, ds; - char *pattern, *name; + const char *pattern, *name; /* * Attempt to open the key for enumeration. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, - (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH)); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); index = 0; result = TCL_OK; @@ -922,13 +884,9 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while ((*regWinProcs->regEnumValueProc)(key, index, - Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) - == ERROR_SUCCESS) { - - if (regWinProcs->useWide) { - size *= 2; - } + while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { + size *= sizeof(TCHAR); Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); @@ -978,12 +936,13 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - int length; + size_t length; HKEY rootKey; DWORD result; - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc((unsigned int) length + 1); + keyName = Tcl_GetString(keyNameObj); + length = keyNameObj->length; + buffer = Tcl_Alloc(length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -999,7 +958,7 @@ OpenKey( } } - ckfree(buffer); + Tcl_Free(buffer); return result; } @@ -1039,7 +998,7 @@ OpenSubKey( if (hostName) { hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey, + result = RegConnectRegistry((TCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1052,23 +1011,29 @@ OpenSubKey( * this key must be closed by the caller. */ - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + if (keyName) { + keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + } if (flags & REG_CREATE) { DWORD create; - result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL, + + result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* * Here we fudge it for this special root key. See MSDN for more info * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. */ + *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, + result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, keyPtr); } - Tcl_DStringFree(&buf); + if (keyName) { + Tcl_DStringFree(&buf); + } /* * Be sure to close the root key since we are done with it now. @@ -1129,8 +1094,9 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendResult(interp, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); + Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } @@ -1182,12 +1148,16 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - CONST char *keyName) /* Name of key to be deleted in external + const TCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ + REGSAM mode) /* Mode flags to pass. */ { DWORD result, size; Tcl_DString subkey; HKEY hKey; + REGSAM saveMode = mode; + static int checkExProc = 0; + static FARPROC regDeleteKeyExProc = NULL; /* * Do not allow NULL or empty key name. @@ -1197,29 +1167,48 @@ RecursiveDeleteKey( return ERROR_BADKEY; } - result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, - KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; + result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, - (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH)); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ size = MAX_KEY_LENGTH; - result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, - Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); + result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName); + /* + * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we + * can't compile with it in. We need to check for it at runtime + * and use it if we find it. + */ + + if (mode && !checkExProc) { + HMODULE handle; + + checkExProc = 1; + handle = GetModuleHandle(TEXT("ADVAPI32")); + regDeleteKeyExProc = (FARPROC) + GetProcAddress(handle, "RegDeleteKeyExW"); + } + if (mode && regDeleteKeyExProc) { + result = regDeleteKeyExProc(startKey, keyName, mode, 0); + } else { + result = RegDeleteKey(startKey, keyName); + } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1251,29 +1240,32 @@ SetValue( Tcl_Obj *keyNameObj, /* Name of key. */ Tcl_Obj *valueNameObj, /* Name of value to set. */ Tcl_Obj *dataObj, /* Data to be written. */ - Tcl_Obj *typeObj) /* Type of data to be written. */ + Tcl_Obj *typeObj, /* Type of data to be written. */ + REGSAM mode) /* Mode flags to pass. */ { int type; + size_t length; DWORD result; HKEY key; - int length; - char *valueName; + const char *valueName; Tcl_DString nameBuf; if (typeObj == NULL) { type = REG_SZ; } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", 0, (int *) &type) != TCL_OK) { - if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); } - if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { return TCL_ERROR; } - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { @@ -1285,8 +1277,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD)type, (DWORD)value); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1307,53 +1299,53 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); + const char *bytes = Tcl_GetString(objv[i]); + + length = objv[i]->length; + Tcl_DStringAppend(&data, bytes, length); /* - * Add a null character to separate this value from the next. We - * accomplish this by growing the string by one byte. Since the - * DString always tacks on an extra null byte, the new byte will - * already be set to null. + * Add a null character to separate this value from the next. */ - Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); + Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); Tcl_DStringFree(&buf); } else if (type == REG_SZ || type == REG_EXPAND_SZ) { Tcl_DString buf; - CONST char *data = Tcl_GetStringFromObj(dataObj, &length); + const char *data = Tcl_GetString(dataObj); - data = Tcl_WinUtfToTChar(data, length, &buf); + length = dataObj->length; + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* - * Include the null in the length, padding if needed for Unicode. + * Include the null in the length, padding if needed for WCHAR. */ - if (regWinProcs->useWide) { - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - } + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { BYTE *data; + int bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, data, (DWORD) length); + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, data, (DWORD) bytelength); } Tcl_DStringFree(&nameBuf); @@ -1389,35 +1381,33 @@ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument values. */ + Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; - UINT timeout = 3000; - int len; - CONST char *str; + int timeout = 3000; + size_t len; + const char *str; Tcl_Obj *objPtr; + WCHAR *wstr; + Tcl_DString ds; - if ((objc != 3) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); - return TCL_ERROR; - } - - if (objc > 3) { - str = Tcl_GetStringFromObj(objv[3], &len); - if ((len < 2) || (*str != '-') - || strncmp(str, "-timeout", (size_t) len)) { - Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); - return TCL_ERROR; + if (objc == 3) { + str = Tcl_GetString(objv[1]); + len = objv[1]->length; + if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { + return TCL_BREAK; } - if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { return TCL_ERROR; } } - str = Tcl_GetStringFromObj(objv[2], &len); - if (len == 0) { - str = NULL; + str = Tcl_GetString(objv[0]); + len = objv[0]->length; + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + if (Tcl_DStringLength(&ds) == 0) { + wstr = NULL; } /* @@ -1425,11 +1415,12 @@ BroadcastValue( */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, - (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); + (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; @@ -1458,8 +1449,8 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr; - char *msg; + TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); @@ -1467,52 +1458,34 @@ AppendSystemError( if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } - length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM + length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { - char *msgPtr; - - length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, - 0, NULL); - if (length > 0) { - wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, - length + 1); - LocalFree(msgPtr); - } - } - if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - msg = "function not supported under Win32s"; - } else { - sprintf(msgBuf, "unknown error: %ld", error); - msg = msgBuf; - } + sprintf(msgBuf, "unknown error: %ld", error); + msg = msgBuf; } else { - Tcl_Encoding encoding; + char *msgPtr; - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); - Tcl_FreeEncoding(encoding); - LocalFree(wMsgPtr); + Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + LocalFree(tMsgPtr); - msg = Tcl_DStringValue(&ds); + msgPtr = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ - if (msg[length-1] == '\n') { - msg[--length] = 0; + if (msgPtr[length-1] == '\n') { + --length; } - if (msg[length-1] == '\r') { - msg[--length] = 0; + if (msgPtr[length-1] == '\r') { + --length; } + msgPtr[length] = 0; + msg = msgPtr; } sprintf(id, "%ld", error); @@ -1547,14 +1520,15 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? (DWORD) SWAPLONG(value) : value; } -- cgit v0.12 From 125b29bfe3ceb7ff21f83db0e6b4dd79d28328c3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Oct 2018 18:41:35 +0000 Subject: tclWinReg.c: Code cleanup. Eliminate some unnecessary variables. tclWinDde.c: Backport improvements (support for TCL_UTF_MAX=6) from androwish: Both androwish and tclsh (all versions) can now use the same dde.dll. dde: bump version --- library/dde/pkgIndex.tcl | 4 +- tests/registry.test | 8 +- tests/winDde.test | 4 +- win/Makefile.in | 4 +- win/makefile.vc | 2 +- win/tclWinDde.c | 294 +++++++++++++++++++++++++---------------------- win/tclWinReg.c | 32 ++---- 7 files changed, 178 insertions(+), 170 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 4cf73d0..7aa67fa 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde] } diff --git a/tests/registry.test b/tests/registry.test index b6be074..539ba2d 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -283,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -487,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { +test registry-6.21 {GetValue: very long value names and values} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -604,7 +604,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { registry values \\\\\\ } -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} -test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body { +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { registry values \\\\\\HKEY_CLASSES_ROOT } -returnCodes error -result {unable to open key: The network address is invalid.} test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { diff --git a/tests/winDde.test b/tests/winDde.test index f04fb45..1fa7e86 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -20,7 +20,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.0] + set ::ddever [package require dde 1.4.1] set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } @@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.0} +} {1.4.1} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/win/Makefile.in b/win/Makefile.in index a8d487b..8ce57f2 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -712,14 +712,14 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tclsh with the proper path,... runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ - package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via diff --git a/win/makefile.vc b/win/makefile.vc index 337a894..0e1e1fd 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -384,7 +384,7 @@ test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << diff --git a/win/tclWinDde.c b/win/tclWinDde.c index ce0b413..6908fdf 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -18,15 +18,6 @@ #include #include -#ifndef UNICODE -# undef CP_WINUNICODE -# define CP_WINUNICODE CP_WINANSI -# undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) -# undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif - #if !defined(NDEBUG) /* test POKE server Implemented for debug mode only */ # undef CBF_FAIL_POKES @@ -34,16 +25,6 @@ #endif /* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init - * declaration is in the source file itself, which is only accessed when we - * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE - * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -/* * The following structure is used to keep track of the interpreters * registered by this process. */ @@ -69,7 +50,7 @@ typedef struct Conversation { Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; -typedef struct DdeEnumServices { +typedef struct { Tcl_Interp *interp; int result; ATOM service; @@ -77,7 +58,7 @@ typedef struct DdeEnumServices { HWND hwnd; } DdeEnumServices; -typedef struct ThreadSpecificData { +typedef struct { Conversation *currentConversations; /* A list of conversations currently being * processed. */ @@ -97,7 +78,7 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.4.0" +#define TCL_DDE_VERSION "1.4.1" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME TEXT("TclEval") #define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") @@ -114,7 +95,7 @@ TCL_DECLARE_MUTEX(ddeMutex) static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static int DdeCreateClient(struct DdeEnumServices *es); +static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); @@ -135,8 +116,9 @@ static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -EXTERN int Dde_Init(Tcl_Interp *interp); -EXTERN int Dde_SafeInit(Tcl_Interp *interp); + +DLLEXPORT int Dde_Init(Tcl_Interp *interp); +DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -162,13 +144,6 @@ Dde_Init( return TCL_ERROR; } -#ifdef UNICODE - if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Win32s and Windows 9x are not supported platforms", -1)); - return TCL_ERROR; - } -#endif Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); @@ -399,7 +374,7 @@ DdeSetServerName( Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); + Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); @@ -414,9 +389,9 @@ DdeSetServerName( * We have found a unique name. Now add it to the registry. */ - riPtr = ckalloc(sizeof(RegisteredInterp)); + riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { @@ -517,7 +492,7 @@ DeleteProc( prevPtr->nextPtr = searchPtr->nextPtr; } } - ckfree(riPtr->name); + Tcl_Free((char *) riPtr->name); if (riPtr->handlerPtr) { Tcl_DecrRefCount(riPtr->handlerPtr); } @@ -555,7 +530,7 @@ ExecuteRemoteObject( Tcl_Obj *returnPackagePtr; int result = TCL_OK; - if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { + if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); @@ -637,7 +612,7 @@ DdeServerProc( /* Transaction-dependent data. */ { Tcl_DString dString; - int len; + size_t len; DWORD dlen; TCHAR *utilString; Tcl_Obj *ddeObjectPtr; @@ -687,7 +662,7 @@ DdeServerProc( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if (_tcsicmp(riPtr->name, utilString) == 0) { - convPtr = ckalloc(sizeof(Conversation)); + convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; @@ -717,7 +692,7 @@ DdeServerProc( if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } - ckfree(convPtr); + Tcl_Free((char *) convPtr); break; } } @@ -743,22 +718,24 @@ DdeServerProc( } if (convPtr != NULL) { + Tcl_DString dsBuf; char *returnString; len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); + Tcl_DStringInit(&dsBuf); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { - if (uFmt == CF_TEXT) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - } else { - returnString = (char *) - Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); - len = sizeof(TCHAR) * len + 1; + returnString = + Tcl_GetString(convPtr->returnPackagePtr); + len = convPtr->returnPackagePtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -768,18 +745,18 @@ DdeServerProc( } else { Tcl_DString ds; Tcl_Obj *variableObjPtr; + Tcl_WinTCharToUtf(utilString, -1, &ds); variableObjPtr = Tcl_GetVar2Ex( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - if (uFmt == CF_TEXT) { - returnString = Tcl_GetStringFromObj( - variableObjPtr, &len); - } else { - returnString = (char *) Tcl_GetUnicodeFromObj( - variableObjPtr, &len); - len = sizeof(TCHAR) * len + 1; + returnString = Tcl_GetString(variableObjPtr); + len = variableObjPtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -790,6 +767,7 @@ DdeServerProc( Tcl_DStringFree(&ds); } } + Tcl_DStringFree(&dsBuf); Tcl_DStringFree(&dString); } return ddeReturn; @@ -814,26 +792,30 @@ DdeServerProc( } if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { - Tcl_DString ds; + Tcl_DString ds, ds2; Tcl_Obj *variableObjPtr; + DWORD len2; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); + Tcl_DStringInit(&ds2); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, CP_WINUNICODE); Tcl_WinTCharToUtf(utilString, -1, &ds); - utilString = (TCHAR *) DdeAccessData(hData, &dlen); - if (uFmt == CF_TEXT) { - variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); - } else { - variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); + utilString = (TCHAR *) DdeAccessData(hData, &len2); + len = len2; + if (uFmt != CF_TEXT) { + Tcl_WinTCharToUtf(utilString, -1, &ds2); + utilString = (TCHAR *) Tcl_DStringValue(&ds2); } + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, variableObjPtr, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds2); Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); ddeReturn = (HDDEDATA) DDE_FACK; @@ -874,8 +856,12 @@ DdeServerProc( ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* unicode */ - dlen >>= 1; - ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1); + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); @@ -1040,7 +1026,7 @@ MakeDdeConnection( static int DdeCreateClient( - struct DdeEnumServices *es) + DdeEnumServices *es) { WNDCLASSEX wc; static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); @@ -1050,7 +1036,7 @@ DdeCreateClient( wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(struct DdeEnumServices *); + wc.cbWndExtra = sizeof(DdeEnumServices *); /* * Register and create the callback window. @@ -1072,8 +1058,8 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - struct DdeEnumServices *es = - (struct DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = + (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); @@ -1098,18 +1084,18 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - struct DdeEnumServices *es; + DdeEnumServices *es; TCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 - es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif - if ((es->service == (ATOM)0 || es->service == service) - && (es->topic == (ATOM)0 || es->topic == topic)) { + if (((es->service == (ATOM)0) || (es->service == service)) + && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); @@ -1156,7 +1142,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + DdeEnumServices *es = (DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -1170,7 +1156,7 @@ DdeGetServicesList( const TCHAR *serviceName, const TCHAR *topicName) { - struct DdeEnumServices es; + DdeEnumServices es; es.interp = interp; es.result = TCL_OK; @@ -1291,7 +1277,8 @@ DdeObjCmd( "-binary", NULL }; - int index, i, length, argIndex; + int index, i, argIndex; + int length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; @@ -1300,6 +1287,7 @@ DdeObjCmd( const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; + Tcl_DString serviceBuf, topicBuf, itemBuf; /* * Initialize DDE server/client @@ -1315,6 +1303,9 @@ DdeObjCmd( return TCL_ERROR; } + Tcl_DStringInit(&serviceBuf); + Tcl_DStringInit(&topicBuf); + Tcl_DStringInit(&itemBuf); switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { @@ -1364,7 +1355,7 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; break; - } else if (objc >= 6 && objc <= 7) { + } else if ((objc >= 6) && (objc <= 7)) { firstArg = objc - 3; for (i = 2; i < firstArg; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, @@ -1449,11 +1440,12 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { -#ifdef UNICODE - serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); -#else - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); -#endif + const char *src = Tcl_GetString(objv[firstArg]); + + length = objv[firstArg]->length; + Tcl_WinUtfToTChar(src, length, &serviceBuf); + serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); } else { length = 0; } @@ -1466,11 +1458,11 @@ DdeObjCmd( } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { -#ifdef UNICODE - topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length); -#else - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); -#endif + const char *src = Tcl_GetString(objv[firstArg + 1]); + + length = objv[firstArg + 1]->length; + topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); if (length == 0) { topicName = NULL; } else { @@ -1484,11 +1476,12 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { -#ifdef UNICODE - Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); -#else - Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); -#endif + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf))); + Tcl_DStringFree(&dsBuf); } else { Tcl_ResetResult(interp); } @@ -1496,20 +1489,27 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - const Tcl_UniChar *dataString; + const void *dataString; + Tcl_DString dsBuf; + Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { - dataString = (const Tcl_UniChar *) + dataString = Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { - dataString = - Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); - dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + dataLength = objv[firstArg + 2]->length; + dataString = (const TCHAR *) + Tcl_WinUtfToTChar(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); } - if (dataLength <= 0) { + if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_DStringFree(&dsBuf); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; @@ -1519,6 +1519,7 @@ DdeObjCmd( DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { + Tcl_DStringFree(&dsBuf); SetDdeError(interp); result = TCL_ERROR; break; @@ -1544,16 +1545,17 @@ DdeObjCmd( SetDdeError(interp); result = TCL_ERROR; } + Tcl_DStringFree(&dsBuf); break; } case DDE_REQUEST: { -#ifdef UNICODE - const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], - &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif + const TCHAR *itemString; + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, @@ -1581,18 +1583,23 @@ DdeObjCmd( result = TCL_ERROR; } else { DWORD tmp; - const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); + TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = - Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); + Tcl_NewByteArrayObj((BYTE *) dataString, tmp); } else { - tmp >>= 1; - if (tmp && !dataString[(tmp-1)]) { - --tmp; + Tcl_DString dsBuf; + + if ((tmp >= sizeof(TCHAR)) + && !dataString[tmp / sizeof(TCHAR) - 1]) { + tmp -= sizeof(TCHAR); } - returnObjPtr = Tcl_NewUnicodeObj(dataString, - (int) tmp); + Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + returnObjPtr = + Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); @@ -1603,19 +1610,18 @@ DdeObjCmd( result = TCL_ERROR; } } - break; } case DDE_POKE: { -#ifdef UNICODE - const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], - &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); -#endif + Tcl_DString dsBuf; + const TCHAR *itemString; BYTE *dataString; + const char *src; + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); @@ -1623,13 +1629,17 @@ DdeObjCmd( result = TCL_ERROR; goto cleanup; } + Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); } else { + const char *data = + Tcl_GetString(objv[firstArg + 3]); + length = objv[firstArg + 3]->length; dataString = (BYTE *) - Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length); - length = 2 * length + 1; + Tcl_WinUtfToTChar(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -1654,6 +1664,7 @@ DdeObjCmd( result = TCL_ERROR; } } + Tcl_DStringFree(&dsBuf); break; } @@ -1712,7 +1723,7 @@ DdeObjCmd( * referring to deallocated objects. */ - if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { + if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( "permission denied: a handler procedure must be" " defined for use in a safe interp", -1)); @@ -1757,8 +1768,7 @@ DdeObjCmd( objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (objPtr) { - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); } objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, @@ -1772,6 +1782,8 @@ DdeObjCmd( Tcl_Release(riPtr); Tcl_Release(sendInterp); } else { + Tcl_DString dsBuf; + /* * This is a non-local request. Send the script to the server and * poll it for a result. @@ -1787,9 +1799,14 @@ DdeObjCmd( } objPtr = Tcl_ConcatObj(objc, objv); - string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); - ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); + string = Tcl_GetString(objPtr); + length = objPtr->length; + Tcl_WinUtfToTChar(string, length, &dsBuf); + string = Tcl_DStringValue(&dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, + (DWORD) length, 0, 0, CF_UNICODETEXT, 0); + Tcl_DStringFree(&dsBuf); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, @@ -1818,7 +1835,7 @@ DdeObjCmd( if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; - Tcl_UniChar *ddeDataString; + TCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1829,13 +1846,17 @@ DdeObjCmd( * variable "errorInfo". */ - resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = ckalloc(length); + ddeDataString = (TCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - length = (length >> 1) - 1; - resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); - ckfree(ddeDataString); + if (length > sizeof(TCHAR)) { + length -= sizeof(TCHAR); + } + Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); + Tcl_Free((char *) ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); @@ -1853,9 +1874,7 @@ DdeObjCmd( Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } - length = -1; - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); @@ -1887,6 +1906,9 @@ DdeObjCmd( if (hConv != NULL) { DdeDisconnect(hConv); } + Tcl_DStringFree(&itemBuf); + Tcl_DStringFree(&topicBuf); + Tcl_DStringFree(&serviceBuf); return result; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f3d7a07..0d2cd94 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -492,7 +492,6 @@ DeleteValue( { HKEY key; char *valueName; - size_t length; DWORD result; Tcl_DString ds; @@ -506,8 +505,7 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - Tcl_WinUtfToTChar(valueName, length, &ds); + Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { @@ -647,7 +645,6 @@ GetType( Tcl_DString ds; const char *valueName; const TCHAR *nativeValue; - size_t length; /* * Attempt to open the key for reading. @@ -663,8 +660,7 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -720,7 +716,6 @@ GetValue( const TCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; - size_t nameLen; /* * Attempt to open the key for reading. @@ -746,8 +741,7 @@ GetValue( length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nameLen = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -936,13 +930,11 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - size_t length; HKEY rootKey; DWORD result; keyName = Tcl_GetString(keyNameObj); - length = keyNameObj->length; - buffer = Tcl_Alloc(length + 1); + buffer = Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1244,7 +1236,6 @@ SetValue( REGSAM mode) /* Mode flags to pass. */ { int type; - size_t length; DWORD result; HKEY key; const char *valueName; @@ -1265,8 +1256,7 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); + valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1301,8 +1291,7 @@ SetValue( for (i = 0; i < objc; i++) { const char *bytes = Tcl_GetString(objv[i]); - length = objv[i]->length; - Tcl_DStringAppend(&data, bytes, length); + Tcl_DStringAppend(&data, bytes, objv[i]->length); /* * Add a null character to separate this value from the next. @@ -1322,18 +1311,16 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - length = dataObj->length; - data = (char *) Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - length = Tcl_DStringLength(&buf) + 1; result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; @@ -1404,8 +1391,7 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - len = objv[0]->length; - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } -- cgit v0.12 From 9654f8c692e08a81dc7e45dd3a5a9e1c8f949596 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 07:53:45 +0000 Subject: tclWinDde.c: Backport version 1.4.1 from Tcl 8.6. --- library/dde/pkgIndex.tcl | 4 +- tests/winDde.test | 290 +++++++++++++---------- win/Makefile.in | 6 +- win/configure | 8 +- win/configure.in | 4 +- win/makefile.bc | 4 +- win/makefile.vc | 4 +- win/tclWinDde.c | 583 +++++++++++++++++++++++++++++++---------------- win/tclWinReg.c | 32 +-- 9 files changed, 580 insertions(+), 355 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 114dee6..065dc83 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde] } diff --git a/tests/winDde.test b/tests/winDde.test index f0ef56c..1fa7e86 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,18 +9,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - package require dde - set ::ddelib [lindex [package ifneeded dde 1.3.3] 1]}]} { + set ::ddever [package require dde 1.4.1] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } } @@ -32,7 +33,7 @@ if {[testConstraint win]} { set scriptName [makeFile {} script1.tcl] -proc createChildProcess {ddeServerName {handler {}}} { +proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] @@ -41,11 +42,11 @@ proc createChildProcess {ddeServerName {handler {}}} { puts $f { # DDE child server - # - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + # If an error occurs during the tests, this process may end up not # being closed down. To deal with this we create a 30s timeout. proc ::DoTimeout {} { @@ -55,16 +56,19 @@ proc createChildProcess {ddeServerName {handler {}}} { flush stdout } set timeout [after 30000 ::DoTimeout] - + # Define a restricted handler. proc Handler1 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts $cmd ; flush stdout + if {$cmd == ""} { + set cmd "null data" + } + puts $cmd ; flush stdout return } proc Handler2 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts [uplevel \#0 $cmd] ; flush stdout + puts [uplevel \#0 $cmd] ; flush stdout return } proc Handler3 {prefix cmd} { @@ -74,11 +78,7 @@ proc createChildProcess {ddeServerName {handler {}}} { } } # set the dde server name to the supplied argument. - if {$handler == {}} { - puts $f [list dde servername $ddeServerName] - } else { - puts $f [list dde servername -handler $handler -- $ddeServerName] - } + puts $f [list dde servername {*}$args -- $ddeServerName] puts $f { # run the server and handle final cleanup. after 200;# give dde a chance to get going. @@ -88,12 +88,12 @@ proc createChildProcess {ddeServerName {handler {}}} { # allow enough time for the calling process to # claim all results, to avoid spurious "server did # not respond" - after 200 { set reallyDone 1 } + after 200 {set reallyDone 1} vwait reallyDone exit } close $f - + # run the child server script. set f [open |[list [interpreter] $::scriptName] r] fconfigure $f -buffering line @@ -102,147 +102,184 @@ proc createChildProcess {ddeServerName {handler {}}} { } # ------------------------------------------------------------------------- +test winDde-1.0 {check if we are testing the right dll} {win dde} { + set ::ddever +} {1.4.1} -test winDde-1.1 {Settings the server's topic name} {win dde} { +test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] -} {foobar foobar self} +} -result {foobar foobar self} -test winDde-2.1 {Checking for other services} {win dde} { +test winDde-2.1 {Checking for other services} -constraints dde -body { expr [llength [dde services {} {}]] >= 0 -} 1 +} -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ - {win dde} { + -constraints dde -body { llength [dde services TclEval self] -} 1 +} -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services TclEval {}]] >= 1 -} 1 +} -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services {} self]] >= 1 -} 1 +} -result 1 # ------------------------------------------------------------------------- -test winDde-3.1 {DDE execute locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - set a -} foo -test winDde-3.2 {DDE execute -async locally} {win dde} { - set a "" - dde execute -async TclEval self {set a "foo"} +test winDde-3.1 {DDE execute locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + set \xe1 +} -result foo +test winDde-3.2 {DDE execute -async locally} -constraints dde -body { + set \xe1 "" + dde execute -async TclEval self [list set \xe1 foo] update - set a -} foo -test winDde-3.3 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request TclEval self a -} foo -test winDde-3.4 {DDE eval locally} {win dde} { - set a "" - dde eval self set a "foo" -} foo -test winDde-3.5 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request -binary TclEval self a -} "foo\x00" + set \xe1 +} -result foo +test winDde-3.3 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + dde request TclEval self \xe1 +} -result foo +test winDde-3.4 {DDE eval locally} -constraints dde -body { + set \xe1 "" + dde eval self set \xe1 foo +} -result foo +test winDde-3.5 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + dde request -binary TclEval self \xe1 +} -result "foo\x00" +# Set variable a to A with diaeresis (unicode C4) by relying on the fact +# that utf8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf8} -constraints dde -body { + set \xe1 "not set" + dde execute TclEval self "set \xe1 \xc4" + scan [set \xe1] %c +} -result 196 +# Set variable a to A with diaeresis (unicode C4) using binary execute +# and compose utf-8 (e.g. "c3 84" ) manualy +test winDde-3.7 {DDE request binary} -constraints dde -body { + set \xe1 "not set" + dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] + scan [set \xe1] %c +} -result 196 +test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke TclEval self \xe1 \xc4 + dde request TclEval self \xe1 +} -result \xc4 +test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke -binary TclEval self \xe1 \xc3\x84\x00 + dde request TclEval self \xe1 +} -result \xc4 # ------------------------------------------------------------------------- -test winDde-4.1 {DDE execute remotely} {stdio win dde} { - set a "" - set name child-4.1 +test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.1 set child [createChildProcess $name] - dde execute TclEval $name {set a "foo"} + dde execute TclEval $name [list set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.2 {DDE execute async remotely} {stdio win dde} { - set a "" - set name child-4.2 + set \xe1 +} -result "" +test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.2 set child [createChildProcess $name] - dde execute -async TclEval $name {set a "foo"} + dde execute -async TclEval $name [list set \xe1 foo] update dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.3 {DDE request remotely} {stdio win dde} { - set a "" - set name chile-4.3 + set \xe1 +} -result "" +test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.3 + set child [createChildProcess $name] + dde execute TclEval $name [list set \xe1 foo] + set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name {set done 1} + update + set \xe1 +} -result foo +test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.4 set child [createChildProcess $name] - dde execute TclEval $name {set a "foo"} - set a [dde request TclEval $name a] + set \xe1 [dde eval $name set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} foo -test winDde-4.4 {DDE eval remotely} {stdio win dde} { - set a "" - set name child-4.4 + set \xe1 +} -result foo +test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { + set \xe1 "" + set name ch\xEDld-4.5 set child [createChildProcess $name] - set a [dde eval $name set a "foo"] + dde poke TclEval $name \xe1 foo + set \xe1 [dde request TclEval $name \xe1] dde execute TclEval $name {set done 1} update - set a -} foo + set \xe1 +} -result foo # ------------------------------------------------------------------------- -test winDde-5.1 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.1 {check for bad arguments} -constraints dde -body { dde execute "" "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.2 {check for bad arguments} -constraints {win dde} -body { - dde execute "" "" "" +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.2 {check for bad arguments} -constraints dde -body { + dde execute -binary "" "" "" } -returnCodes error -result {cannot execute null data} -test winDde-5.3 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.3 {check for bad arguments} -constraints dde -body { dde execute -foo "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.4 {DDE eval bad arguments} -constraints dde -body { dde eval "" "foo" } -returnCodes error -result {invalid service name ""} # ------------------------------------------------------------------------- -test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { +test winDde-6.1 {DDE servername bad arguments} -constraints dde -body { dde servername -z -z -z } -returnCodes error -result {bad option "-z": must be -force, -handler, or --} -test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { +test winDde-6.2 {DDE servername set name} -constraints dde -body { dde servername -- winDde-6.2 } -result {winDde-6.2} -test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.3 {DDE servername set exact name} -constraints dde -body { dde servername -force winDde-6.3 } -result {winDde-6.3} -test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.4 {DDE servername set exact name} -constraints dde -body { dde servername -force -- winDde-6.4 } -result {winDde-6.4} -test winDde-6.5 {DDE remote servername collision} -constraints {stdio win dde} -setup { - set name child-6.5 +test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup { + set name ch\xEDld-6.5 set child [createChildProcess $name] } -body { dde servername -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result "child-6.5 #2" -test winDde-6.6 {DDE remote servername collision force} -constraints {stdio win dde} -setup { - set name child-6.6 +} -result "ch\xEDld-6.5 #2" +test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup { + set name ch\xEDld-6.6 set child [createChildProcess $name] } -body { dde servername -force -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result {child-6.6} +} -result "ch\xEDld-6.6" # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { +test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { interp create slave } -body { slave eval [list load $::ddelib Dde] @@ -250,7 +287,7 @@ test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { +test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.5] @@ -259,11 +296,11 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { + if {$m in $s} { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { +test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.3] @@ -272,7 +309,7 @@ test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {{TclEval dde-interp-7.3}} -test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setup { +test winDde-7.4 {interp name collision with -force} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.4] @@ -281,7 +318,7 @@ test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setu } -cleanup { interp delete slave } -result {dde-interp-7.4} -test winDde-7.5 {interp name collision without -force} -constraints {win dde} -setup { +test winDde-7.5 {interp name collision without -force} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.5] @@ -293,7 +330,7 @@ test winDde-7.5 {interp name collision without -force} -constraints {win dde} -s # ------------------------------------------------------------------------- -test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { +test winDde-8.1 {Safe DDE load} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { @@ -301,20 +338,20 @@ test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { } -cleanup { interp delete slave } -returnCodes error -result {invalid command name "dde"} -test winDde-8.2 {Safe DDE set servername} -constraints {win dde} -setup { +test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { slave invokehidden dde servername slave } -cleanup {interp delete slave} -result {slave} -test winDde-8.3 {Safe DDE check handler required for eval} -constraints {win dde} -setup { +test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave } -body { catch {dde eval slave set a 1} msg } -cleanup {interp delete slave} -result {1} -test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -setup { +test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave @@ -323,7 +360,7 @@ test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} - dde execute TclEval slave {set a 2} slave eval set a } -cleanup {interp delete slave} -result 1 -test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -setup { +test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave @@ -333,14 +370,14 @@ test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} - } -cleanup { interp delete slave } -returnCodes error -result {remote server cannot handle this command} -test winDde-8.6 {Safe DDE assign handler procedure} -constraints {win dde} -setup { +test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { slave invokehidden dde servername -handler DDEACCEPT slave } -cleanup {interp delete slave} -result slave -test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { +test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} @@ -348,7 +385,7 @@ test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { } -body { dde eval slave set x 1 } -cleanup {interp delete slave} -result {set x 1} -test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup { +test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} @@ -358,16 +395,16 @@ test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup dde eval slave $s string equal [slave eval set DDECMD] $s } -cleanup {interp delete slave} -result 1 -test winDde-8.9 {Safe DDE check command evaluation} -constraints {win dde} -setup { +test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} slave invokehidden dde servername -handler DDEACCEPT slave } -body { - dde eval slave set x 1 - slave eval set x + dde eval slave set \xe1 1 + slave eval set \xe1 } -cleanup {interp delete slave} -result 1 -test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} -setup { +test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} @@ -376,7 +413,7 @@ test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} dde eval slave [list set x 1] slave eval set x } -cleanup {interp delete slave} -result 1 -test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} -setup { +test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} @@ -388,9 +425,9 @@ test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} # ------------------------------------------------------------------------- -test winDde-9.1 {External safe DDE check string passing} -constraints {win dde stdio} -setup { - set name child-9.1 - set child [createChildProcess $name Handler1] +test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.1 + set child [createChildProcess $name -handler Handler1] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -401,9 +438,9 @@ test winDde-9.1 {External safe DDE check string passing} -constraints {win dde s update file delete -force -- dde-script.tcl } -result {set x 1} -test winDde-9.2 {External safe DDE check command evaluation} -constraints {win dde stdio} -setup { - set name child-9.2 - set child [createChildProcess $name Handler2] +test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup { + set name ch\xEDld-9.2 + set child [createChildProcess $name -handler Handler2] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -414,9 +451,9 @@ test winDde-9.2 {External safe DDE check command evaluation} -constraints {win d update file delete -force -- dde-script.tcl } -result 1 -test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win dde stdio} -setup { - set name child-9.3 - set child [createChildProcess $name [list Handler3 ARG]] +test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup { + set name ch\xEDld-9.3 + set child [createChildProcess $name -handler [list Handler3 ARG]] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -427,6 +464,19 @@ test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win d update file delete -force -- dde-script.tcl } -result {ARG {set x 1}} +test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.4 + set child [createChildProcess $name -handler Handler1] + file copy -force script1.tcl dde-script.tcl +} -body { + dde execute TclEval $name "" + gets $child line + set line +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {null data} # ------------------------------------------------------------------------- diff --git a/win/Makefile.in b/win/Makefile.in index 6d1ce95..7fc415d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -498,7 +498,7 @@ tclWinReg.${OBJEXT} : tclWinReg.c $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) tclWinDde.${OBJEXT} : tclWinDde.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) # TIP #59, embedding of configuration information into the binary library. # @@ -709,13 +709,13 @@ install-private-headers: libraries test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tcltest with the proper path,... runtest: binaries $(TCLTEST) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via diff --git a/win/configure b/win/configure index 3fe89bf..3a77f00 100755 --- a/win/configure +++ b/win/configure @@ -1314,14 +1314,14 @@ TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.2 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=2 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/configure.in b/win/configure.in index fa75e5b..12c81ed 100644 --- a/win/configure.in +++ b/win/configure.in @@ -17,9 +17,9 @@ TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 diff --git a/win/makefile.bc b/win/makefile.bc index 20d89bc..577c865 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -127,8 +127,8 @@ STUBPREFIX = $(NAMEPREFIX)stub DOTVERSION = 8.5 VERSION = 85 -DDEVERSION = 13 -DDEDOTVERSION = 1.3 +DDEVERSION = 14 +DDEDOTVERSION = 1.4 REGVERSION = 13 REGDOTVERSION = 1.3 diff --git a/win/makefile.vc b/win/makefile.vc index c330fcd..62a4d67 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -538,13 +538,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.1 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry] << type tests.log | more diff --git a/win/tclWinDde.c b/win/tclWinDde.c index eef5caa..38f1d88 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -10,20 +10,20 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" -#include "tclPort.h" #include #include +#include -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init - * declaration is in the source file itself, which is only accessed when we - * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE - * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT +#if !defined(NDEBUG) + /* test POKE server Implemented for debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +#endif /* * The following structure is used to keep track of the interpreters @@ -34,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - char *name; /* Interpreter's name (malloc-ed). */ + TCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -51,7 +51,7 @@ typedef struct Conversation { Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; -typedef struct DdeEnumServices { +typedef struct { Tcl_Interp *interp; int result; ATOM service; @@ -59,7 +59,7 @@ typedef struct DdeEnumServices { HWND hwnd; } DdeEnumServices; -typedef struct ThreadSpecificData { +typedef struct { Conversation *currentConversations; /* A list of conversations currently being * processed. */ @@ -79,9 +79,10 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; +#define TCL_DDE_VERSION "1.4.1" #define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME "TclEval" -#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" +#define TCL_DDE_SERVICE_NAME TEXT("TclEval") +#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 @@ -95,12 +96,12 @@ TCL_DECLARE_MUTEX(ddeMutex) static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static int DdeCreateClient(struct DdeEnumServices *es); +static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const char *serviceName, const char *topicName); + const TCHAR *serviceName, const TCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -110,14 +111,15 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const char *name, HCONV *ddeConvPtr); + const TCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -EXTERN int Dde_Init(Tcl_Interp *interp); -EXTERN int Dde_SafeInit(Tcl_Interp *interp); + +DLLEXPORT int Dde_Init(Tcl_Interp *interp); +DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -145,7 +147,7 @@ Dde_Init( Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3"); + return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); } /* @@ -229,7 +231,7 @@ Initialize(void) ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, 0); + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; @@ -263,10 +265,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const char * +static const TCHAR * DdeSetServerName( Tcl_Interp *interp, - const char *name, /* The name that will be used to refer to the + const TCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ @@ -276,7 +278,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const char *actualName; + const TCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -314,7 +316,7 @@ DdeSetServerName( * current interp, but it doesn't have a name. */ - return ""; + return TEXT(""); } /* @@ -335,7 +337,9 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - OutputDebugString(Tcl_GetStringResult(interp)); + Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); + OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringFree(&dString); return NULL; } @@ -352,13 +356,14 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, name, -1); - Tcl_DStringAppend(&dString, " #", 2); + Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE); - actualName = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); + actualName = (TCHAR *) Tcl_DStringValue(&dString); } - sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); + _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, TEXT("%d"), suffix); } /* @@ -367,39 +372,41 @@ DdeSetServerName( for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; + Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) { + Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); + if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; + Tcl_DStringFree(&ds); break; } + Tcl_DStringFree(&ds); } } - Tcl_DStringSetLength(&dString, - offset + (int)strlen(Tcl_DStringValue(&dString)+offset)); } /* * We have found a unique name. Now add it to the registry. */ - riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); + riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1); + riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; - strcpy(riPtr->name, actualName); + _tcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, - (ClientData) riPtr, DeleteProc); + riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } @@ -486,7 +493,7 @@ DeleteProc( prevPtr->nextPtr = searchPtr->nextPtr; } } - ckfree(riPtr->name); + Tcl_Free((char *) riPtr->name); if (riPtr->handlerPtr) { Tcl_DecrRefCount(riPtr->handlerPtr); } @@ -524,10 +531,11 @@ ExecuteRemoteObject( Tcl_Obj *returnPackagePtr; int result = TCL_OK; - if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { + if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); + Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; } @@ -605,9 +613,9 @@ DdeServerProc( /* Transaction-dependent data. */ { Tcl_DString dString; - int len; + size_t len; DWORD dlen; - char *utilString; + TCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -621,16 +629,16 @@ DdeServerProc( * sure we have a valid topic. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(utilString, riPtr->name) == 0) { + if (_tcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } @@ -646,16 +654,16 @@ DdeServerProc( * result to return in an XTYP_REQUEST. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(riPtr->name, utilString) == 0) { - convPtr = (Conversation *) ckalloc(sizeof(Conversation)); + if (_tcsicmp(riPtr->name, utilString) == 0) { + convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; @@ -685,7 +693,7 @@ DdeServerProc( if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } - ckfree((char *) convPtr); + Tcl_Free((char *) convPtr); break; } } @@ -711,22 +719,24 @@ DdeServerProc( } if (convPtr != NULL) { + Tcl_DString dsBuf; char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringInit(&dsBuf); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINANSI); - if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { - if (uFmt == CF_TEXT) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - } else { - returnString = (char *) - Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); - len = 2 * len + 1; + CP_WINUNICODE); + if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + returnString = + Tcl_GetString(convPtr->returnPackagePtr); + len = convPtr->returnPackagePtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -734,17 +744,20 @@ DdeServerProc( if (Tcl_IsSafe(convPtr->riPtr->interp)) { ddeReturn = NULL; } else { - Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, utilString, NULL, + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + Tcl_WinTCharToUtf(utilString, -1, &ds); + variableObjPtr = Tcl_GetVar2Ex( + convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - if (uFmt == CF_TEXT) { - returnString = Tcl_GetStringFromObj( - variableObjPtr, &len); - } else { - returnString = (char *) Tcl_GetUnicodeFromObj( - variableObjPtr, &len); - len = 2 * len + 1; + returnString = Tcl_GetString(variableObjPtr); + len = variableObjPtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -752,12 +765,65 @@ DdeServerProc( } else { ddeReturn = NULL; } + Tcl_DStringFree(&ds); } } + Tcl_DStringFree(&dsBuf); + Tcl_DStringFree(&dString); + } + return ddeReturn; + +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds, ds2; + Tcl_Obj *variableObjPtr; + DWORD len2; + + Tcl_DStringInit(&dString); + Tcl_DStringInit(&ds2); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &len2); + len = len2; + if (uFmt != CF_TEXT) { + Tcl_WinTCharToUtf(utilString, -1, &ds2); + utilString = (TCHAR *) Tcl_DStringValue(&ds2); + } + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds2); + Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; } return ddeReturn; +#endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object @@ -765,7 +831,7 @@ DdeServerProc( */ Tcl_Obj *returnPackagePtr; - Tcl_UniChar *uniStr; + char *string; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { @@ -778,21 +844,25 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (char *) DdeAccessData(hData, &dlen); - uniStr = (Tcl_UniChar *) utilString; + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + string = (char *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); - } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) { + } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { /* Cannot be unicode, so assume utf-8 */ - if (!utilString[dlen-1]) { + if (!string[dlen-1]) { dlen--; } - ddeObjectPtr = Tcl_NewStringObj(utilString, dlen); + ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* unicode */ - dlen >>= 1; - ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen - 1); + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); @@ -845,9 +915,9 @@ DdeServerProc( for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINANSI); + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, - riPtr->name, CP_WINANSI); + riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; @@ -905,14 +975,14 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const char *name, /* The connection to use. */ + const TCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -920,8 +990,13 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", NULL); + Tcl_DString dString; + + Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", Tcl_DStringValue(&dString))); + Tcl_DStringFree(&dString); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; } @@ -952,17 +1027,17 @@ MakeDdeConnection( static int DdeCreateClient( - struct DdeEnumServices *es) + DdeEnumServices *es) { WNDCLASSEX wc; - static const char *szDdeClientClassName = "TclEval client class"; - static const char *szDdeClientWindowName = "TclEval client window"; + static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(struct DdeEnumServices *); + wc.cbWndExtra = sizeof(DdeEnumServices *); /* * Register and create the callback window. @@ -984,8 +1059,8 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - struct DdeEnumServices *es = - (struct DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = + (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); @@ -1010,24 +1085,29 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - struct DdeEnumServices *es; - char sz[255]; + DdeEnumServices *es; + TCHAR sz[255]; + Tcl_DString dString; #ifdef _WIN64 - es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif - if ((es->service == (ATOM)0 || es->service == service) - && (es->topic == (ATOM)0 || es->topic == topic)) { + if (((es->service == (ATOM)0) || (es->service == service)) + && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); GlobalGetAtomName(topic, sz, 255); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique @@ -1063,7 +1143,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + DdeEnumServices *es = (DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -1074,10 +1154,10 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const char *serviceName, - const char *topicName) + const TCHAR *serviceName, + const TCHAR *topicName) { - struct DdeEnumServices es; + DdeEnumServices es; es.interp = interp; es.result = TCL_OK; @@ -1122,25 +1202,30 @@ static void SetDdeError( Tcl_Interp *interp) /* The interp to put the message in. */ { - const char *errorMessage; + const char *errorMessage, *errorCode; switch (DdeGetLastError(ddeInstance)) { case DMLERR_DATAACKTIMEOUT: case DMLERR_EXECACKTIMEOUT: case DMLERR_POKEACKTIMEOUT: errorMessage = "remote interpreter did not respond"; + errorCode = "TIMEOUT"; break; case DMLERR_BUSY: errorMessage = "remote server is busy"; + errorCode = "BUSY"; break; case DMLERR_NOTPROCESSED: errorMessage = "remote server cannot handle this command"; + errorCode = "NOCANDO"; break; default: errorMessage = "dde command failed"; + errorCode = "FAILED"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); } /* @@ -1167,34 +1252,43 @@ DdeObjCmd( int objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { - static const char *ddeCommands[] = { + static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", (char *) NULL}; enum DdeSubcommands { DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, DDE_EVAL }; - static const char *ddeSrvOptions[] = { + static const char *const ddeSrvOptions[] = { "-force", "-handler", "--", NULL }; enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; - static const char *ddeExecOptions[] = { + static const char *const ddeExecOptions[] = { + "-async", "-binary", NULL + }; + enum DdeExecOptions { + DDE_EXEC_ASYNC, DDE_EXEC_BINARY + }; + static const char *const ddeEvalOptions[] = { "-async", NULL }; - static const char *ddeReqOptions[] = { + static const char *const ddeReqOptions[] = { "-binary", NULL }; - int index, i, length, argIndex; + int index, i, argIndex; + int length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const char *serviceName = NULL, *topicName = NULL, *string; + const TCHAR *serviceName = NULL, *topicName = NULL; + const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; + Tcl_DString serviceBuf, topicBuf, itemBuf; /* * Initialize DDE server/client @@ -1210,6 +1304,9 @@ DdeObjCmd( return TCL_ERROR; } + Tcl_DStringInit(&serviceBuf); + Tcl_DStringInit(&topicBuf); + Tcl_DStringInit(&itemBuf); switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { @@ -1259,38 +1356,53 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, - &argIndex) == TCL_OK) { - flags |= DDE_FLAG_ASYNC; - firstArg = 3; - break; + } else if ((objc >= 6) && (objc <= 7)) { + firstArg = objc - 3; + for (i = 2; i < firstArg; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, + "option", 0, &argIndex) != TCL_OK) { + goto wrongDdeExecuteArgs; + } + if (argIndex == DDE_EXEC_ASYNC) { + flags |= DDE_FLAG_ASYNC; + } else { + flags |= DDE_FLAG_BINARY; + } } + break; } /* otherwise... */ + wrongDdeExecuteArgs: Tcl_WrongNumArgs(interp, 2, objv, - "?-async? serviceName topicName value"); + "?-async? ?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_POKE: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "serviceName topicName item value"); - return TCL_ERROR; + if (objc == 6) { + firstArg = 2; + break; + } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; } - firstArg = 2; - break; + + /* + * Otherwise... + */ + + Tcl_WrongNumArgs(interp, 2, objv, + "?-binary? serviceName topicName item value"); + return TCL_ERROR; case DDE_REQUEST: if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - int dummy; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, - &dummy) == TCL_OK) { - flags |= DDE_FLAG_BINARY; - firstArg = 3; - break; - } + } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; } /* @@ -1314,7 +1426,7 @@ DdeObjCmd( return TCL_ERROR; } else { firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; @@ -1329,7 +1441,12 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); + const char *src = Tcl_GetString(objv[firstArg]); + + length = objv[firstArg]->length; + Tcl_WinUtfToTChar(src, length, &serviceBuf); + serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); } else { length = 0; } @@ -1338,16 +1455,20 @@ DdeObjCmd( serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, - CP_WINANSI); + CP_WINUNICODE); } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); + const char *src = Tcl_GetString(objv[firstArg + 1]); + + length = objv[firstArg + 1]->length; + topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); if (length == 0) { topicName = NULL; } else { ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, - CP_WINANSI); + CP_WINUNICODE); } } @@ -1356,7 +1477,12 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf))); + Tcl_DStringFree(&dsBuf); } else { Tcl_ResetResult(interp); } @@ -1364,12 +1490,28 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - BYTE *dataString = (BYTE *) Tcl_GetStringFromObj( - objv[firstArg + 2], &dataLength); + const void *dataString; + Tcl_DString dsBuf; + + Tcl_DStringInit(&dsBuf); + if (flags & DDE_FLAG_BINARY) { + dataString = + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + } else { + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + dataLength = objv[firstArg + 2]->length; + dataString = (const TCHAR *) + Tcl_WinUtfToTChar(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + } - if (dataLength == 0) { + if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_DStringFree(&dsBuf); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; } @@ -1378,21 +1520,22 @@ DdeObjCmd( DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { + Tcl_DStringFree(&dsBuf); SetDdeError(interp); result = TCL_ERROR; break; } - ddeData = DdeCreateDataHandle(ddeInstance, dataString, - (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); + ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, + (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; @@ -1403,15 +1546,22 @@ DdeObjCmd( SetDdeError(interp); result = TCL_ERROR; } + Tcl_DStringFree(&dsBuf); break; } case DDE_REQUEST: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); + const TCHAR *itemString; + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } @@ -1424,27 +1574,33 @@ DdeObjCmd( result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString, - CP_WINANSI); + ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); + TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = - Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); + Tcl_NewByteArrayObj((BYTE *) dataString, tmp); } else { - if (tmp && !dataString[tmp-1]) { - --tmp; + Tcl_DString dsBuf; + + if ((tmp >= sizeof(TCHAR)) + && !dataString[tmp / sizeof(TCHAR) - 1]) { + tmp -= sizeof(TCHAR); } - returnObjPtr = Tcl_NewStringObj(dataString, - (int) tmp); + Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + returnObjPtr = + Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); @@ -1455,22 +1611,37 @@ DdeObjCmd( result = TCL_ERROR; } } - break; } case DDE_POKE: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); + Tcl_DString dsBuf; + const TCHAR *itemString; BYTE *dataString; + const char *src; + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } - dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], - &length); + Tcl_DStringInit(&dsBuf); + if (flags & DDE_FLAG_BINARY) { + dataString = (BYTE *) + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + } else { + const char *data = + Tcl_GetString(objv[firstArg + 3]); + length = objv[firstArg + 3]->length; + dataString = (BYTE *) + Tcl_WinUtfToTChar(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -1481,10 +1652,10 @@ DdeObjCmd( result = TCL_ERROR; } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINANSI); + CP_WINUNICODE); if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString, (DWORD) length+1, - hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); + ddeData = DdeClientTransaction(dataString, (DWORD) length, + hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; @@ -1494,6 +1665,7 @@ DdeObjCmd( result = TCL_ERROR; } } + Tcl_DStringFree(&dsBuf); break; } @@ -1508,6 +1680,7 @@ DdeObjCmd( if (serviceName == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid service name \"\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); result = TCL_ERROR; goto cleanup; } @@ -1526,7 +1699,7 @@ DdeObjCmd( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(serviceName, riPtr->name) == 0) { + if (_tcsicmp(serviceName, riPtr->name) == 0) { break; } } @@ -1539,9 +1712,9 @@ DdeObjCmd( * server. */ - Tcl_Preserve((ClientData) riPtr); + Tcl_Preserve(riPtr); sendInterp = riPtr->interp; - Tcl_Preserve((ClientData) sendInterp); + Tcl_Preserve(sendInterp); /* * Don't exchange objects between interps. The target interp would @@ -1551,10 +1724,12 @@ DdeObjCmd( * referring to deallocated objects. */ - if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { - Tcl_SetResult(riPtr->interp, "permission denied: " - "a handler procedure must be defined for use in " - "a safe interp", TCL_STATIC); + if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + "permission denied: a handler procedure must be" + " defined for use in a safe interp", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", + NULL); result = TCL_ERROR; } @@ -1594,8 +1769,7 @@ DdeObjCmd( objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (objPtr) { - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); } objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, @@ -1606,9 +1780,11 @@ DdeObjCmd( } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } - Tcl_Release((ClientData) riPtr); - Tcl_Release((ClientData) sendInterp); + Tcl_Release(riPtr); + Tcl_Release(sendInterp); } else { + Tcl_DString dsBuf; + /* * This is a non-local request. Send the script to the server and * poll it for a result. @@ -1617,31 +1793,36 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", - -1)); + Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); - ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); + string = Tcl_GetString(objPtr); + length = objPtr->length; + Tcl_WinUtfToTChar(string, length, &dsBuf); + string = Tcl_DStringValue(&dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, + (DWORD) length, 0, 0, CF_UNICODETEXT, 0); + Tcl_DStringFree(&dsBuf); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, - TCL_DDE_EXECUTE_RESULT, CP_WINANSI); + TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1650,10 +1831,12 @@ DdeObjCmd( if (ddeData == 0) { SetDdeError(interp); result = TCL_ERROR; + goto cleanup; } if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; + TCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1664,12 +1847,17 @@ DdeObjCmd( * variable "errorInfo". */ - resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, length); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); - Tcl_SetObjLength(resultPtr, (int) strlen(string)); + ddeDataString = (TCHAR *) Tcl_Alloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + if (length > sizeof(TCHAR)) { + length -= sizeof(TCHAR); + } + Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); + Tcl_Free((char *) ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); @@ -1687,9 +1875,7 @@ DdeObjCmd( Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } - length = -1; - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); @@ -1721,6 +1907,9 @@ DdeObjCmd( if (hConv != NULL) { DdeDisconnect(hConv); } + Tcl_DStringFree(&itemBuf); + Tcl_DStringFree(&topicBuf); + Tcl_DStringFree(&serviceBuf); return result; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f3d7a07..0d2cd94 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -492,7 +492,6 @@ DeleteValue( { HKEY key; char *valueName; - size_t length; DWORD result; Tcl_DString ds; @@ -506,8 +505,7 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - Tcl_WinUtfToTChar(valueName, length, &ds); + Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { @@ -647,7 +645,6 @@ GetType( Tcl_DString ds; const char *valueName; const TCHAR *nativeValue; - size_t length; /* * Attempt to open the key for reading. @@ -663,8 +660,7 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -720,7 +716,6 @@ GetValue( const TCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; - size_t nameLen; /* * Attempt to open the key for reading. @@ -746,8 +741,7 @@ GetValue( length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nameLen = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -936,13 +930,11 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - size_t length; HKEY rootKey; DWORD result; keyName = Tcl_GetString(keyNameObj); - length = keyNameObj->length; - buffer = Tcl_Alloc(length + 1); + buffer = Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1244,7 +1236,6 @@ SetValue( REGSAM mode) /* Mode flags to pass. */ { int type; - size_t length; DWORD result; HKEY key; const char *valueName; @@ -1265,8 +1256,7 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); + valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1301,8 +1291,7 @@ SetValue( for (i = 0; i < objc; i++) { const char *bytes = Tcl_GetString(objv[i]); - length = objv[i]->length; - Tcl_DStringAppend(&data, bytes, length); + Tcl_DStringAppend(&data, bytes, objv[i]->length); /* * Add a null character to separate this value from the next. @@ -1322,18 +1311,16 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - length = dataObj->length; - data = (char *) Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - length = Tcl_DStringLength(&buf) + 1; result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; @@ -1404,8 +1391,7 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - len = objv[0]->length; - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } -- cgit v0.12 From d7a697aa505f57e3135239964c90863202c4f815 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 08:03:56 +0000 Subject: Missed some version bumps in previous commit --- win/makefile.vc | 2 +- win/rules.vc | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 62a4d67..95a34d7 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -182,7 +182,7 @@ STUBPREFIX = $(PROJECT)stub DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -DDEDOTVERSION = 1.3 +DDEDOTVERSION = 1.4 DDEVERSION = $(DDEDOTVERSION:.=) REGDOTVERSION = 1.3 diff --git a/win/rules.vc b/win/rules.vc index 0ae0e8e..33ebfe2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -591,7 +591,7 @@ TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" @@ -604,7 +604,7 @@ TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" -- cgit v0.12 From fef802ea7a250bb158b599340431c49d115184c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 08:06:42 +0000 Subject: Update to latest tzdata (backported from 8.6) --- library/tzdata/Africa/Ceuta | 1 + library/tzdata/America/Santiago | 324 ++++++++++++++++++++-------------------- library/tzdata/Asia/Macau | 68 ++++++--- library/tzdata/Asia/Manila | 18 +-- library/tzdata/Asia/Pyongyang | 2 +- library/tzdata/Asia/Shanghai | 43 +++--- library/tzdata/Asia/Tokyo | 8 +- library/tzdata/Europe/Volgograd | 1 + library/tzdata/Pacific/Easter | 324 ++++++++++++++++++++-------------------- library/tzdata/Pacific/Fiji | 24 +-- 10 files changed, 427 insertions(+), 386 deletions(-) diff --git a/library/tzdata/Africa/Ceuta b/library/tzdata/Africa/Ceuta index 057ca22..18af8c1 100644 --- a/library/tzdata/Africa/Ceuta +++ b/library/tzdata/Africa/Ceuta @@ -15,6 +15,7 @@ set TZData(:Africa/Ceuta) { {-1316390400 3600 1 WEST} {-1301270400 0 0 WET} {-1293840000 0 0 WET} + {-94694400 0 0 WET} {-81432000 3600 1 WEST} {-71110800 0 0 WET} {141264000 3600 1 WEST} diff --git a/library/tzdata/America/Santiago b/library/tzdata/America/Santiago index 67d5b5c..55212b9 100644 --- a/library/tzdata/America/Santiago +++ b/library/tzdata/America/Santiago @@ -124,166 +124,166 @@ set TZData(:America/Santiago) { {1502596800 -10800 1 -04} {1526180400 -14400 0 -04} {1534046400 -10800 1 -04} - {1557630000 -14400 0 -04} - {1565496000 -10800 1 -04} - {1589079600 -14400 0 -04} - {1596945600 -10800 1 -04} - {1620529200 -14400 0 -04} - {1629000000 -10800 1 -04} - {1652583600 -14400 0 -04} - {1660449600 -10800 1 -04} - {1684033200 -14400 0 -04} - {1691899200 -10800 1 -04} - {1715482800 -14400 0 -04} - {1723348800 -10800 1 -04} - {1746932400 -14400 0 -04} - {1754798400 -10800 1 -04} - {1778382000 -14400 0 -04} - {1786248000 -10800 1 -04} - {1809831600 -14400 0 -04} - {1818302400 -10800 1 -04} - {1841886000 -14400 0 -04} - {1849752000 -10800 1 -04} - {1873335600 -14400 0 -04} - {1881201600 -10800 1 -04} - {1904785200 -14400 0 -04} - {1912651200 -10800 1 -04} - {1936234800 -14400 0 -04} - {1944100800 -10800 1 -04} - {1967684400 -14400 0 -04} - {1976155200 -10800 1 -04} - {1999738800 -14400 0 -04} - {2007604800 -10800 1 -04} - {2031188400 -14400 0 -04} - {2039054400 -10800 1 -04} - {2062638000 -14400 0 -04} - {2070504000 -10800 1 -04} - {2094087600 -14400 0 -04} - {2101953600 -10800 1 -04} - {2125537200 -14400 0 -04} - {2133403200 -10800 1 -04} - {2156986800 -14400 0 -04} - {2165457600 -10800 1 -04} - {2189041200 -14400 0 -04} - {2196907200 -10800 1 -04} - {2220490800 -14400 0 -04} - {2228356800 -10800 1 -04} - {2251940400 -14400 0 -04} - {2259806400 -10800 1 -04} - {2283390000 -14400 0 -04} - {2291256000 -10800 1 -04} - {2314839600 -14400 0 -04} - {2322705600 -10800 1 -04} - {2346894000 -14400 0 -04} - {2354760000 -10800 1 -04} - {2378343600 -14400 0 -04} - {2386209600 -10800 1 -04} - {2409793200 -14400 0 -04} - {2417659200 -10800 1 -04} - {2441242800 -14400 0 -04} - {2449108800 -10800 1 -04} - {2472692400 -14400 0 -04} - {2480558400 -10800 1 -04} - {2504142000 -14400 0 -04} - {2512612800 -10800 1 -04} - {2536196400 -14400 0 -04} - {2544062400 -10800 1 -04} - {2567646000 -14400 0 -04} - {2575512000 -10800 1 -04} - {2599095600 -14400 0 -04} - {2606961600 -10800 1 -04} - {2630545200 -14400 0 -04} - {2638411200 -10800 1 -04} - {2661994800 -14400 0 -04} - {2669860800 -10800 1 -04} - {2693444400 -14400 0 -04} - {2701915200 -10800 1 -04} - {2725498800 -14400 0 -04} - {2733364800 -10800 1 -04} - {2756948400 -14400 0 -04} - {2764814400 -10800 1 -04} - {2788398000 -14400 0 -04} - {2796264000 -10800 1 -04} - {2819847600 -14400 0 -04} - {2827713600 -10800 1 -04} - {2851297200 -14400 0 -04} - {2859768000 -10800 1 -04} - {2883351600 -14400 0 -04} - {2891217600 -10800 1 -04} - {2914801200 -14400 0 -04} - {2922667200 -10800 1 -04} - {2946250800 -14400 0 -04} - {2954116800 -10800 1 -04} - {2977700400 -14400 0 -04} - {2985566400 -10800 1 -04} - {3009150000 -14400 0 -04} - {3017016000 -10800 1 -04} - {3040599600 -14400 0 -04} - {3049070400 -10800 1 -04} - {3072654000 -14400 0 -04} - {3080520000 -10800 1 -04} - {3104103600 -14400 0 -04} - {3111969600 -10800 1 -04} - {3135553200 -14400 0 -04} - {3143419200 -10800 1 -04} - {3167002800 -14400 0 -04} - {3174868800 -10800 1 -04} - {3198452400 -14400 0 -04} - {3206318400 -10800 1 -04} - {3230506800 -14400 0 -04} - {3238372800 -10800 1 -04} - {3261956400 -14400 0 -04} - {3269822400 -10800 1 -04} - {3293406000 -14400 0 -04} - {3301272000 -10800 1 -04} - {3324855600 -14400 0 -04} - {3332721600 -10800 1 -04} - {3356305200 -14400 0 -04} - {3364171200 -10800 1 -04} - {3387754800 -14400 0 -04} - {3396225600 -10800 1 -04} - {3419809200 -14400 0 -04} - {3427675200 -10800 1 -04} - {3451258800 -14400 0 -04} - {3459124800 -10800 1 -04} - {3482708400 -14400 0 -04} - {3490574400 -10800 1 -04} - {3514158000 -14400 0 -04} - {3522024000 -10800 1 -04} - {3545607600 -14400 0 -04} - {3553473600 -10800 1 -04} - {3577057200 -14400 0 -04} - {3585528000 -10800 1 -04} - {3609111600 -14400 0 -04} - {3616977600 -10800 1 -04} - {3640561200 -14400 0 -04} - {3648427200 -10800 1 -04} - {3672010800 -14400 0 -04} - {3679876800 -10800 1 -04} - {3703460400 -14400 0 -04} - {3711326400 -10800 1 -04} - {3734910000 -14400 0 -04} - {3743380800 -10800 1 -04} - {3766964400 -14400 0 -04} - {3774830400 -10800 1 -04} - {3798414000 -14400 0 -04} - {3806280000 -10800 1 -04} - {3829863600 -14400 0 -04} - {3837729600 -10800 1 -04} - {3861313200 -14400 0 -04} - {3869179200 -10800 1 -04} - {3892762800 -14400 0 -04} - {3900628800 -10800 1 -04} - {3924212400 -14400 0 -04} - {3932683200 -10800 1 -04} - {3956266800 -14400 0 -04} - {3964132800 -10800 1 -04} - {3987716400 -14400 0 -04} - {3995582400 -10800 1 -04} - {4019166000 -14400 0 -04} - {4027032000 -10800 1 -04} - {4050615600 -14400 0 -04} - {4058481600 -10800 1 -04} - {4082065200 -14400 0 -04} - {4089931200 -10800 1 -04} + {1554606000 -14400 0 -04} + {1567915200 -10800 1 -04} + {1586055600 -14400 0 -04} + {1599364800 -10800 1 -04} + {1617505200 -14400 0 -04} + {1630814400 -10800 1 -04} + {1648954800 -14400 0 -04} + {1662264000 -10800 1 -04} + {1680404400 -14400 0 -04} + {1693713600 -10800 1 -04} + {1712458800 -14400 0 -04} + {1725768000 -10800 1 -04} + {1743908400 -14400 0 -04} + {1757217600 -10800 1 -04} + {1775358000 -14400 0 -04} + {1788667200 -10800 1 -04} + {1806807600 -14400 0 -04} + {1820116800 -10800 1 -04} + {1838257200 -14400 0 -04} + {1851566400 -10800 1 -04} + {1870311600 -14400 0 -04} + {1883016000 -10800 1 -04} + {1901761200 -14400 0 -04} + {1915070400 -10800 1 -04} + {1933210800 -14400 0 -04} + {1946520000 -10800 1 -04} + {1964660400 -14400 0 -04} + {1977969600 -10800 1 -04} + {1996110000 -14400 0 -04} + {2009419200 -10800 1 -04} + {2027559600 -14400 0 -04} + {2040868800 -10800 1 -04} + {2059614000 -14400 0 -04} + {2072318400 -10800 1 -04} + {2091063600 -14400 0 -04} + {2104372800 -10800 1 -04} + {2122513200 -14400 0 -04} + {2135822400 -10800 1 -04} + {2153962800 -14400 0 -04} + {2167272000 -10800 1 -04} + {2185412400 -14400 0 -04} + {2198721600 -10800 1 -04} + {2217466800 -14400 0 -04} + {2230171200 -10800 1 -04} + {2248916400 -14400 0 -04} + {2262225600 -10800 1 -04} + {2280366000 -14400 0 -04} + {2293675200 -10800 1 -04} + {2311815600 -14400 0 -04} + {2325124800 -10800 1 -04} + {2343265200 -14400 0 -04} + {2356574400 -10800 1 -04} + {2374714800 -14400 0 -04} + {2388024000 -10800 1 -04} + {2406769200 -14400 0 -04} + {2419473600 -10800 1 -04} + {2438218800 -14400 0 -04} + {2451528000 -10800 1 -04} + {2469668400 -14400 0 -04} + {2482977600 -10800 1 -04} + {2501118000 -14400 0 -04} + {2514427200 -10800 1 -04} + {2532567600 -14400 0 -04} + {2545876800 -10800 1 -04} + {2564017200 -14400 0 -04} + {2577326400 -10800 1 -04} + {2596071600 -14400 0 -04} + {2609380800 -10800 1 -04} + {2627521200 -14400 0 -04} + {2640830400 -10800 1 -04} + {2658970800 -14400 0 -04} + {2672280000 -10800 1 -04} + {2690420400 -14400 0 -04} + {2703729600 -10800 1 -04} + {2721870000 -14400 0 -04} + {2735179200 -10800 1 -04} + {2753924400 -14400 0 -04} + {2766628800 -10800 1 -04} + {2785374000 -14400 0 -04} + {2798683200 -10800 1 -04} + {2816823600 -14400 0 -04} + {2830132800 -10800 1 -04} + {2848273200 -14400 0 -04} + {2861582400 -10800 1 -04} + {2879722800 -14400 0 -04} + {2893032000 -10800 1 -04} + {2911172400 -14400 0 -04} + {2924481600 -10800 1 -04} + {2943226800 -14400 0 -04} + {2955931200 -10800 1 -04} + {2974676400 -14400 0 -04} + {2987985600 -10800 1 -04} + {3006126000 -14400 0 -04} + {3019435200 -10800 1 -04} + {3037575600 -14400 0 -04} + {3050884800 -10800 1 -04} + {3069025200 -14400 0 -04} + {3082334400 -10800 1 -04} + {3101079600 -14400 0 -04} + {3113784000 -10800 1 -04} + {3132529200 -14400 0 -04} + {3145838400 -10800 1 -04} + {3163978800 -14400 0 -04} + {3177288000 -10800 1 -04} + {3195428400 -14400 0 -04} + {3208737600 -10800 1 -04} + {3226878000 -14400 0 -04} + {3240187200 -10800 1 -04} + {3258327600 -14400 0 -04} + {3271636800 -10800 1 -04} + {3290382000 -14400 0 -04} + {3303086400 -10800 1 -04} + {3321831600 -14400 0 -04} + {3335140800 -10800 1 -04} + {3353281200 -14400 0 -04} + {3366590400 -10800 1 -04} + {3384730800 -14400 0 -04} + {3398040000 -10800 1 -04} + {3416180400 -14400 0 -04} + {3429489600 -10800 1 -04} + {3447630000 -14400 0 -04} + {3460939200 -10800 1 -04} + {3479684400 -14400 0 -04} + {3492993600 -10800 1 -04} + {3511134000 -14400 0 -04} + {3524443200 -10800 1 -04} + {3542583600 -14400 0 -04} + {3555892800 -10800 1 -04} + {3574033200 -14400 0 -04} + {3587342400 -10800 1 -04} + {3605482800 -14400 0 -04} + {3618792000 -10800 1 -04} + {3637537200 -14400 0 -04} + {3650241600 -10800 1 -04} + {3668986800 -14400 0 -04} + {3682296000 -10800 1 -04} + {3700436400 -14400 0 -04} + {3713745600 -10800 1 -04} + {3731886000 -14400 0 -04} + {3745195200 -10800 1 -04} + {3763335600 -14400 0 -04} + {3776644800 -10800 1 -04} + {3794785200 -14400 0 -04} + {3808094400 -10800 1 -04} + {3826839600 -14400 0 -04} + {3839544000 -10800 1 -04} + {3858289200 -14400 0 -04} + {3871598400 -10800 1 -04} + {3889738800 -14400 0 -04} + {3903048000 -10800 1 -04} + {3921188400 -14400 0 -04} + {3934497600 -10800 1 -04} + {3952638000 -14400 0 -04} + {3965947200 -10800 1 -04} + {3984692400 -14400 0 -04} + {3997396800 -10800 1 -04} + {4016142000 -14400 0 -04} + {4029451200 -10800 1 -04} + {4047591600 -14400 0 -04} + {4060900800 -10800 1 -04} + {4079041200 -14400 0 -04} + {4092350400 -10800 1 -04} } diff --git a/library/tzdata/Asia/Macau b/library/tzdata/Asia/Macau index 76a00aa..cbafd0e 100644 --- a/library/tzdata/Asia/Macau +++ b/library/tzdata/Asia/Macau @@ -1,20 +1,56 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Macau) { - {-9223372036854775808 27260 0 LMT} - {-1830412800 28800 0 CST} + {-9223372036854775808 27250 0 LMT} + {-2056692850 28800 0 CST} + {-884509200 32400 0 +09} + {-873280800 36000 1 +09} + {-855918000 32400 0 +09} + {-841744800 36000 1 +09} + {-828529200 32400 0 +10} + {-765363600 28800 0 CT} + {-747046800 32400 1 CDT} + {-733827600 28800 0 CST} + {-716461200 32400 1 CDT} + {-697021200 28800 0 CST} + {-683715600 32400 1 CDT} + {-667990800 28800 0 CST} + {-654771600 32400 1 CDT} + {-636627600 28800 0 CST} + {-623322000 32400 1 CDT} + {-605178000 28800 0 CST} + {-591872400 32400 1 CDT} + {-573642000 28800 0 CST} + {-559818000 32400 1 CDT} + {-541674000 28800 0 CST} + {-528368400 32400 1 CDT} + {-510224400 28800 0 CST} + {-498128400 32400 1 CDT} + {-478774800 28800 0 CST} + {-466678800 32400 1 CDT} + {-446720400 28800 0 CST} + {-435229200 32400 1 CDT} + {-415258200 28800 0 CST} + {-403158600 32400 1 CDT} + {-383808600 28800 0 CST} + {-371709000 32400 1 CDT} + {-352359000 28800 0 CST} + {-340259400 32400 1 CDT} + {-320909400 28800 0 CST} + {-308809800 32400 1 CDT} + {-288855000 28800 0 CST} {-277360200 32400 1 CDT} {-257405400 28800 0 CST} {-245910600 32400 1 CDT} {-225955800 28800 0 CST} - {-214473600 32400 1 CDT} + {-213856200 32400 1 CDT} {-194506200 28800 0 CST} {-182406600 32400 1 CDT} {-163056600 28800 0 CST} - {-150969600 32400 1 CDT} - {-131619600 28800 0 CST} + {-148537800 32400 1 CDT} + {-132820200 28800 0 CST} {-117088200 32400 1 CDT} - {-101367000 28800 0 CST} + {-101370600 28800 0 CST} {-85638600 32400 1 CDT} {-69312600 28800 0 CST} {-53584200 32400 1 CDT} @@ -25,22 +61,16 @@ set TZData(:Asia/Macau) { {25036200 28800 0 CST} {40764600 32400 1 CDT} {56485800 28800 0 CST} - {72201600 32400 1 CDT} - {87922800 28800 0 CST} - {103651200 32400 1 CDT} - {119977200 28800 0 CST} - {135705600 32400 1 CDT} + {72214200 32400 1 CDT} + {88540200 28800 0 CST} + {104268600 32400 1 CDT} + {119989800 28800 0 CST} + {126041400 32400 1 CDT} {151439400 28800 0 CST} {167167800 32400 1 CDT} {182889000 28800 0 CST} {198617400 32400 1 CDT} {214338600 28800 0 CST} - {230067000 32400 1 CDT} - {245788200 28800 0 CST} - {261504000 32400 1 CDT} - {277225200 28800 0 CST} - {292953600 32400 1 CDT} - {309279600 28800 0 CST} - {325008000 32400 1 CDT} - {340729200 28800 0 CST} + {295385400 32400 1 CDT} + {309292200 28800 0 CST} } diff --git a/library/tzdata/Asia/Manila b/library/tzdata/Asia/Manila index b7ffa7a..6eb1db3 100644 --- a/library/tzdata/Asia/Manila +++ b/library/tzdata/Asia/Manila @@ -3,13 +3,13 @@ set TZData(:Asia/Manila) { {-9223372036854775808 -57360 0 LMT} {-3944621040 29040 0 LMT} - {-2229321840 28800 0 +08} - {-1046678400 32400 1 +08} - {-1038733200 28800 0 +08} - {-873273600 32400 0 +09} - {-794221200 28800 0 +08} - {-496224000 32400 1 +08} - {-489315600 28800 0 +08} - {259344000 32400 1 +08} - {275151600 28800 0 +08} + {-2229321840 28800 0 PST} + {-1046678400 32400 1 PDT} + {-1038733200 28800 0 PST} + {-873273600 32400 0 JST} + {-794221200 28800 0 PST} + {-496224000 32400 1 PDT} + {-489315600 28800 0 PST} + {259344000 32400 1 PDT} + {275151600 28800 0 PST} } diff --git a/library/tzdata/Asia/Pyongyang b/library/tzdata/Asia/Pyongyang index 5746472..5351736 100644 --- a/library/tzdata/Asia/Pyongyang +++ b/library/tzdata/Asia/Pyongyang @@ -6,5 +6,5 @@ set TZData(:Asia/Pyongyang) { {-1830414600 32400 0 JST} {-768646800 32400 0 KST} {1439564400 30600 0 KST} - {1525447800 32400 0 KST} + {1525446000 32400 0 KST} } diff --git a/library/tzdata/Asia/Shanghai b/library/tzdata/Asia/Shanghai index ff2d2b5..66bc4339 100644 --- a/library/tzdata/Asia/Shanghai +++ b/library/tzdata/Asia/Shanghai @@ -3,21 +3,30 @@ set TZData(:Asia/Shanghai) { {-9223372036854775808 29143 0 LMT} {-2177481943 28800 0 CST} - {-933494400 32400 1 CDT} - {-923130000 28800 0 CST} - {-908784000 32400 1 CDT} - {-891594000 28800 0 CST} - {-662716800 28800 0 CST} - {515520000 32400 1 CDT} - {527007600 28800 0 CST} - {545155200 32400 1 CDT} - {558457200 28800 0 CST} - {576604800 32400 1 CDT} - {589906800 28800 0 CST} - {608659200 32400 1 CDT} - {621961200 28800 0 CST} - {640108800 32400 1 CDT} - {653410800 28800 0 CST} - {671558400 32400 1 CDT} - {684860400 28800 0 CST} + {-933667200 32400 1 CDT} + {-922093200 28800 0 CST} + {-908870400 32400 1 CDT} + {-888829200 28800 0 CST} + {-881049600 32400 1 CDT} + {-767869200 28800 0 CST} + {-745833600 32400 1 CDT} + {-733827600 28800 0 CST} + {-716889600 32400 1 CDT} + {-699613200 28800 0 CST} + {-683884800 32400 1 CDT} + {-670669200 28800 0 CST} + {-652348800 32400 1 CDT} + {-650016000 28800 0 CST} + {515527200 32400 1 CDT} + {527014800 28800 0 CST} + {545162400 32400 1 CDT} + {558464400 28800 0 CST} + {577216800 32400 1 CDT} + {589914000 28800 0 CST} + {608666400 32400 1 CDT} + {621968400 28800 0 CST} + {640116000 32400 1 CDT} + {653418000 28800 0 CST} + {671565600 32400 1 CDT} + {684867600 28800 0 CST} } diff --git a/library/tzdata/Asia/Tokyo b/library/tzdata/Asia/Tokyo index 790df0a..cc7a857 100644 --- a/library/tzdata/Asia/Tokyo +++ b/library/tzdata/Asia/Tokyo @@ -4,11 +4,11 @@ set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-683802000 36000 1 JDT} - {-672314400 32400 0 JST} + {-672310800 32400 0 JST} {-654771600 36000 1 JDT} - {-640864800 32400 0 JST} + {-640861200 32400 0 JST} {-620298000 36000 1 JDT} - {-609415200 32400 0 JST} + {-609411600 32400 0 JST} {-588848400 36000 1 JDT} - {-577965600 32400 0 JST} + {-577962000 32400 0 JST} } diff --git a/library/tzdata/Europe/Volgograd b/library/tzdata/Europe/Volgograd index 05e1044..3938683 100644 --- a/library/tzdata/Europe/Volgograd +++ b/library/tzdata/Europe/Volgograd @@ -68,4 +68,5 @@ set TZData(:Europe/Volgograd) { {1288479600 10800 0 +03} {1301180400 14400 0 +04} {1414274400 10800 0 +03} + {1540681200 14400 0 +04} } diff --git a/library/tzdata/Pacific/Easter b/library/tzdata/Pacific/Easter index a087cd0..7a8d525 100644 --- a/library/tzdata/Pacific/Easter +++ b/library/tzdata/Pacific/Easter @@ -103,166 +103,166 @@ set TZData(:Pacific/Easter) { {1502596800 -18000 1 -06} {1526180400 -21600 0 -06} {1534046400 -18000 1 -06} - {1557630000 -21600 0 -06} - {1565496000 -18000 1 -06} - {1589079600 -21600 0 -06} - {1596945600 -18000 1 -06} - {1620529200 -21600 0 -06} - {1629000000 -18000 1 -06} - {1652583600 -21600 0 -06} - {1660449600 -18000 1 -06} - {1684033200 -21600 0 -06} - {1691899200 -18000 1 -06} - {1715482800 -21600 0 -06} - {1723348800 -18000 1 -06} - {1746932400 -21600 0 -06} - {1754798400 -18000 1 -06} - {1778382000 -21600 0 -06} - {1786248000 -18000 1 -06} - {1809831600 -21600 0 -06} - {1818302400 -18000 1 -06} - {1841886000 -21600 0 -06} - {1849752000 -18000 1 -06} - {1873335600 -21600 0 -06} - {1881201600 -18000 1 -06} - {1904785200 -21600 0 -06} - {1912651200 -18000 1 -06} - {1936234800 -21600 0 -06} - {1944100800 -18000 1 -06} - {1967684400 -21600 0 -06} - {1976155200 -18000 1 -06} - {1999738800 -21600 0 -06} - {2007604800 -18000 1 -06} - {2031188400 -21600 0 -06} - {2039054400 -18000 1 -06} - {2062638000 -21600 0 -06} - {2070504000 -18000 1 -06} - {2094087600 -21600 0 -06} - {2101953600 -18000 1 -06} - {2125537200 -21600 0 -06} - {2133403200 -18000 1 -06} - {2156986800 -21600 0 -06} - {2165457600 -18000 1 -06} - {2189041200 -21600 0 -06} - {2196907200 -18000 1 -06} - {2220490800 -21600 0 -06} - {2228356800 -18000 1 -06} - {2251940400 -21600 0 -06} - {2259806400 -18000 1 -06} - {2283390000 -21600 0 -06} - {2291256000 -18000 1 -06} - {2314839600 -21600 0 -06} - {2322705600 -18000 1 -06} - {2346894000 -21600 0 -06} - {2354760000 -18000 1 -06} - {2378343600 -21600 0 -06} - {2386209600 -18000 1 -06} - {2409793200 -21600 0 -06} - {2417659200 -18000 1 -06} - {2441242800 -21600 0 -06} - {2449108800 -18000 1 -06} - {2472692400 -21600 0 -06} - {2480558400 -18000 1 -06} - {2504142000 -21600 0 -06} - {2512612800 -18000 1 -06} - {2536196400 -21600 0 -06} - {2544062400 -18000 1 -06} - {2567646000 -21600 0 -06} - {2575512000 -18000 1 -06} - {2599095600 -21600 0 -06} - {2606961600 -18000 1 -06} - {2630545200 -21600 0 -06} - {2638411200 -18000 1 -06} - {2661994800 -21600 0 -06} - {2669860800 -18000 1 -06} - {2693444400 -21600 0 -06} - {2701915200 -18000 1 -06} - {2725498800 -21600 0 -06} - {2733364800 -18000 1 -06} - {2756948400 -21600 0 -06} - {2764814400 -18000 1 -06} - {2788398000 -21600 0 -06} - {2796264000 -18000 1 -06} - {2819847600 -21600 0 -06} - {2827713600 -18000 1 -06} - {2851297200 -21600 0 -06} - {2859768000 -18000 1 -06} - {2883351600 -21600 0 -06} - {2891217600 -18000 1 -06} - {2914801200 -21600 0 -06} - {2922667200 -18000 1 -06} - {2946250800 -21600 0 -06} - {2954116800 -18000 1 -06} - {2977700400 -21600 0 -06} - {2985566400 -18000 1 -06} - {3009150000 -21600 0 -06} - {3017016000 -18000 1 -06} - {3040599600 -21600 0 -06} - {3049070400 -18000 1 -06} - {3072654000 -21600 0 -06} - {3080520000 -18000 1 -06} - {3104103600 -21600 0 -06} - {3111969600 -18000 1 -06} - {3135553200 -21600 0 -06} - {3143419200 -18000 1 -06} - {3167002800 -21600 0 -06} - {3174868800 -18000 1 -06} - {3198452400 -21600 0 -06} - {3206318400 -18000 1 -06} - {3230506800 -21600 0 -06} - {3238372800 -18000 1 -06} - {3261956400 -21600 0 -06} - {3269822400 -18000 1 -06} - {3293406000 -21600 0 -06} - {3301272000 -18000 1 -06} - {3324855600 -21600 0 -06} - {3332721600 -18000 1 -06} - {3356305200 -21600 0 -06} - {3364171200 -18000 1 -06} - {3387754800 -21600 0 -06} - {3396225600 -18000 1 -06} - {3419809200 -21600 0 -06} - {3427675200 -18000 1 -06} - {3451258800 -21600 0 -06} - {3459124800 -18000 1 -06} - {3482708400 -21600 0 -06} - {3490574400 -18000 1 -06} - {3514158000 -21600 0 -06} - {3522024000 -18000 1 -06} - {3545607600 -21600 0 -06} - {3553473600 -18000 1 -06} - {3577057200 -21600 0 -06} - {3585528000 -18000 1 -06} - {3609111600 -21600 0 -06} - {3616977600 -18000 1 -06} - {3640561200 -21600 0 -06} - {3648427200 -18000 1 -06} - {3672010800 -21600 0 -06} - {3679876800 -18000 1 -06} - {3703460400 -21600 0 -06} - {3711326400 -18000 1 -06} - {3734910000 -21600 0 -06} - {3743380800 -18000 1 -06} - {3766964400 -21600 0 -06} - {3774830400 -18000 1 -06} - {3798414000 -21600 0 -06} - {3806280000 -18000 1 -06} - {3829863600 -21600 0 -06} - {3837729600 -18000 1 -06} - {3861313200 -21600 0 -06} - {3869179200 -18000 1 -06} - {3892762800 -21600 0 -06} - {3900628800 -18000 1 -06} - {3924212400 -21600 0 -06} - {3932683200 -18000 1 -06} - {3956266800 -21600 0 -06} - {3964132800 -18000 1 -06} - {3987716400 -21600 0 -06} - {3995582400 -18000 1 -06} - {4019166000 -21600 0 -06} - {4027032000 -18000 1 -06} - {4050615600 -21600 0 -06} - {4058481600 -18000 1 -06} - {4082065200 -21600 0 -06} - {4089931200 -18000 1 -06} + {1554606000 -21600 0 -06} + {1567915200 -18000 1 -06} + {1586055600 -21600 0 -06} + {1599364800 -18000 1 -06} + {1617505200 -21600 0 -06} + {1630814400 -18000 1 -06} + {1648954800 -21600 0 -06} + {1662264000 -18000 1 -06} + {1680404400 -21600 0 -06} + {1693713600 -18000 1 -06} + {1712458800 -21600 0 -06} + {1725768000 -18000 1 -06} + {1743908400 -21600 0 -06} + {1757217600 -18000 1 -06} + {1775358000 -21600 0 -06} + {1788667200 -18000 1 -06} + {1806807600 -21600 0 -06} + {1820116800 -18000 1 -06} + {1838257200 -21600 0 -06} + {1851566400 -18000 1 -06} + {1870311600 -21600 0 -06} + {1883016000 -18000 1 -06} + {1901761200 -21600 0 -06} + {1915070400 -18000 1 -06} + {1933210800 -21600 0 -06} + {1946520000 -18000 1 -06} + {1964660400 -21600 0 -06} + {1977969600 -18000 1 -06} + {1996110000 -21600 0 -06} + {2009419200 -18000 1 -06} + {2027559600 -21600 0 -06} + {2040868800 -18000 1 -06} + {2059614000 -21600 0 -06} + {2072318400 -18000 1 -06} + {2091063600 -21600 0 -06} + {2104372800 -18000 1 -06} + {2122513200 -21600 0 -06} + {2135822400 -18000 1 -06} + {2153962800 -21600 0 -06} + {2167272000 -18000 1 -06} + {2185412400 -21600 0 -06} + {2198721600 -18000 1 -06} + {2217466800 -21600 0 -06} + {2230171200 -18000 1 -06} + {2248916400 -21600 0 -06} + {2262225600 -18000 1 -06} + {2280366000 -21600 0 -06} + {2293675200 -18000 1 -06} + {2311815600 -21600 0 -06} + {2325124800 -18000 1 -06} + {2343265200 -21600 0 -06} + {2356574400 -18000 1 -06} + {2374714800 -21600 0 -06} + {2388024000 -18000 1 -06} + {2406769200 -21600 0 -06} + {2419473600 -18000 1 -06} + {2438218800 -21600 0 -06} + {2451528000 -18000 1 -06} + {2469668400 -21600 0 -06} + {2482977600 -18000 1 -06} + {2501118000 -21600 0 -06} + {2514427200 -18000 1 -06} + {2532567600 -21600 0 -06} + {2545876800 -18000 1 -06} + {2564017200 -21600 0 -06} + {2577326400 -18000 1 -06} + {2596071600 -21600 0 -06} + {2609380800 -18000 1 -06} + {2627521200 -21600 0 -06} + {2640830400 -18000 1 -06} + {2658970800 -21600 0 -06} + {2672280000 -18000 1 -06} + {2690420400 -21600 0 -06} + {2703729600 -18000 1 -06} + {2721870000 -21600 0 -06} + {2735179200 -18000 1 -06} + {2753924400 -21600 0 -06} + {2766628800 -18000 1 -06} + {2785374000 -21600 0 -06} + {2798683200 -18000 1 -06} + {2816823600 -21600 0 -06} + {2830132800 -18000 1 -06} + {2848273200 -21600 0 -06} + {2861582400 -18000 1 -06} + {2879722800 -21600 0 -06} + {2893032000 -18000 1 -06} + {2911172400 -21600 0 -06} + {2924481600 -18000 1 -06} + {2943226800 -21600 0 -06} + {2955931200 -18000 1 -06} + {2974676400 -21600 0 -06} + {2987985600 -18000 1 -06} + {3006126000 -21600 0 -06} + {3019435200 -18000 1 -06} + {3037575600 -21600 0 -06} + {3050884800 -18000 1 -06} + {3069025200 -21600 0 -06} + {3082334400 -18000 1 -06} + {3101079600 -21600 0 -06} + {3113784000 -18000 1 -06} + {3132529200 -21600 0 -06} + {3145838400 -18000 1 -06} + {3163978800 -21600 0 -06} + {3177288000 -18000 1 -06} + {3195428400 -21600 0 -06} + {3208737600 -18000 1 -06} + {3226878000 -21600 0 -06} + {3240187200 -18000 1 -06} + {3258327600 -21600 0 -06} + {3271636800 -18000 1 -06} + {3290382000 -21600 0 -06} + {3303086400 -18000 1 -06} + {3321831600 -21600 0 -06} + {3335140800 -18000 1 -06} + {3353281200 -21600 0 -06} + {3366590400 -18000 1 -06} + {3384730800 -21600 0 -06} + {3398040000 -18000 1 -06} + {3416180400 -21600 0 -06} + {3429489600 -18000 1 -06} + {3447630000 -21600 0 -06} + {3460939200 -18000 1 -06} + {3479684400 -21600 0 -06} + {3492993600 -18000 1 -06} + {3511134000 -21600 0 -06} + {3524443200 -18000 1 -06} + {3542583600 -21600 0 -06} + {3555892800 -18000 1 -06} + {3574033200 -21600 0 -06} + {3587342400 -18000 1 -06} + {3605482800 -21600 0 -06} + {3618792000 -18000 1 -06} + {3637537200 -21600 0 -06} + {3650241600 -18000 1 -06} + {3668986800 -21600 0 -06} + {3682296000 -18000 1 -06} + {3700436400 -21600 0 -06} + {3713745600 -18000 1 -06} + {3731886000 -21600 0 -06} + {3745195200 -18000 1 -06} + {3763335600 -21600 0 -06} + {3776644800 -18000 1 -06} + {3794785200 -21600 0 -06} + {3808094400 -18000 1 -06} + {3826839600 -21600 0 -06} + {3839544000 -18000 1 -06} + {3858289200 -21600 0 -06} + {3871598400 -18000 1 -06} + {3889738800 -21600 0 -06} + {3903048000 -18000 1 -06} + {3921188400 -21600 0 -06} + {3934497600 -18000 1 -06} + {3952638000 -21600 0 -06} + {3965947200 -18000 1 -06} + {3984692400 -21600 0 -06} + {3997396800 -18000 1 -06} + {4016142000 -21600 0 -06} + {4029451200 -18000 1 -06} + {4047591600 -21600 0 -06} + {4060900800 -18000 1 -06} + {4079041200 -21600 0 -06} + {4092350400 -18000 1 -06} } diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index 610c191..b05985c 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -26,7 +26,7 @@ set TZData(:Pacific/Fiji) { {1509804000 46800 1 +12} {1515852000 43200 0 +12} {1541253600 46800 1 +12} - {1547906400 43200 0 +12} + {1547301600 43200 0 +12} {1572703200 46800 1 +12} {1579356000 43200 0 +12} {1604152800 46800 1 +12} @@ -48,7 +48,7 @@ set TZData(:Pacific/Fiji) { {1856959200 46800 1 +12} {1863007200 43200 0 +12} {1888408800 46800 1 +12} - {1895061600 43200 0 +12} + {1894456800 43200 0 +12} {1919858400 46800 1 +12} {1926511200 43200 0 +12} {1951308000 46800 1 +12} @@ -60,7 +60,7 @@ set TZData(:Pacific/Fiji) { {2046261600 46800 1 +12} {2052309600 43200 0 +12} {2077711200 46800 1 +12} - {2084364000 43200 0 +12} + {2083759200 43200 0 +12} {2109160800 46800 1 +12} {2115813600 43200 0 +12} {2140610400 46800 1 +12} @@ -70,7 +70,7 @@ set TZData(:Pacific/Fiji) { {2204114400 46800 1 +12} {2210162400 43200 0 +12} {2235564000 46800 1 +12} - {2242216800 43200 0 +12} + {2241612000 43200 0 +12} {2267013600 46800 1 +12} {2273666400 43200 0 +12} {2298463200 46800 1 +12} @@ -82,7 +82,7 @@ set TZData(:Pacific/Fiji) { {2393416800 46800 1 +12} {2399464800 43200 0 +12} {2424866400 46800 1 +12} - {2431519200 43200 0 +12} + {2430914400 43200 0 +12} {2456316000 46800 1 +12} {2462968800 43200 0 +12} {2487765600 46800 1 +12} @@ -104,7 +104,7 @@ set TZData(:Pacific/Fiji) { {2740572000 46800 1 +12} {2746620000 43200 0 +12} {2772021600 46800 1 +12} - {2778674400 43200 0 +12} + {2778069600 43200 0 +12} {2803471200 46800 1 +12} {2810124000 43200 0 +12} {2834920800 46800 1 +12} @@ -116,7 +116,7 @@ set TZData(:Pacific/Fiji) { {2929874400 46800 1 +12} {2935922400 43200 0 +12} {2961324000 46800 1 +12} - {2967976800 43200 0 +12} + {2967372000 43200 0 +12} {2992773600 46800 1 +12} {2999426400 43200 0 +12} {3024223200 46800 1 +12} @@ -126,7 +126,7 @@ set TZData(:Pacific/Fiji) { {3087727200 46800 1 +12} {3093775200 43200 0 +12} {3119176800 46800 1 +12} - {3125829600 43200 0 +12} + {3125224800 43200 0 +12} {3150626400 46800 1 +12} {3157279200 43200 0 +12} {3182076000 46800 1 +12} @@ -138,7 +138,7 @@ set TZData(:Pacific/Fiji) { {3277029600 46800 1 +12} {3283077600 43200 0 +12} {3308479200 46800 1 +12} - {3315132000 43200 0 +12} + {3314527200 43200 0 +12} {3339928800 46800 1 +12} {3346581600 43200 0 +12} {3371378400 46800 1 +12} @@ -160,7 +160,7 @@ set TZData(:Pacific/Fiji) { {3624184800 46800 1 +12} {3630232800 43200 0 +12} {3655634400 46800 1 +12} - {3662287200 43200 0 +12} + {3661682400 43200 0 +12} {3687084000 46800 1 +12} {3693736800 43200 0 +12} {3718533600 46800 1 +12} @@ -172,7 +172,7 @@ set TZData(:Pacific/Fiji) { {3813487200 46800 1 +12} {3819535200 43200 0 +12} {3844936800 46800 1 +12} - {3851589600 43200 0 +12} + {3850984800 43200 0 +12} {3876386400 46800 1 +12} {3883039200 43200 0 +12} {3907836000 46800 1 +12} @@ -182,7 +182,7 @@ set TZData(:Pacific/Fiji) { {3971340000 46800 1 +12} {3977388000 43200 0 +12} {4002789600 46800 1 +12} - {4009442400 43200 0 +12} + {4008837600 43200 0 +12} {4034239200 46800 1 +12} {4040892000 43200 0 +12} {4065688800 46800 1 +12} -- cgit v0.12 From 5f392f74b688af273b3efd7f1a6a073f3c24dcb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jos=C3=A9=20Ignacio=20Mar=C3=ADn?= Date: Sat, 27 Oct 2018 18:07:35 +0000 Subject: Update TZ info to tzdata2018g. --- library/tzdata/Africa/Casablanca | 280 ++++++++------------------------------- library/tzdata/Africa/El_Aaiun | 256 ++++++----------------------------- library/tzdata/Pacific/Honolulu | 5 +- 3 files changed, 101 insertions(+), 440 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 33ad99b..3207e59 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -2,229 +2,59 @@ set TZData(:Africa/Casablanca) { {-9223372036854775808 -1820 0 LMT} - {-1773012580 0 0 WET} - {-956361600 3600 1 WEST} - {-950490000 0 0 WET} - {-942019200 3600 1 WEST} - {-761187600 0 0 WET} - {-617241600 3600 1 WEST} - {-605149200 0 0 WET} - {-81432000 3600 1 WEST} - {-71110800 0 0 WET} - {141264000 3600 1 WEST} - {147222000 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {448243200 3600 0 CET} - {504918000 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {-1773012580 0 0 +00} + {-956361600 3600 1 +00} + {-950490000 0 0 +00} + {-942019200 3600 1 +00} + {-761187600 0 0 +00} + {-617241600 3600 1 +00} + {-605149200 0 0 +00} + {-81432000 3600 1 +00} + {-71110800 0 0 +00} + {141264000 3600 1 +00} + {147222000 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {448243200 3600 0 +01} + {504918000 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 7bdc496..e0f5e1c 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -3,217 +3,47 @@ set TZData(:Africa/El_Aaiun) { {-9223372036854775808 -3168 0 LMT} {-1136070432 -3600 0 -01} - {198291600 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {198291600 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu index 5e70598..7d03b45 100644 --- a/library/tzdata/Pacific/Honolulu +++ b/library/tzdata/Pacific/Honolulu @@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) { {-9223372036854775808 -37886 0 LMT} {-2334101314 -37800 0 HST} {-1157283000 -34200 1 HDT} - {-1155436200 -37800 0 HST} - {-880198200 -34200 1 HDT} + {-1155436200 -34200 0 HST} + {-880201800 -34200 1 HWT} + {-769395600 -34200 1 HPT} {-765376200 -37800 0 HST} {-712150200 -36000 0 HST} } -- cgit v0.12 From fbc8feeb407fc9f2ddbf11fa089e56184952581f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:33:40 +0000 Subject: Backport various minor issues from 8.6: - gcc compiler warning in tclDate.c - protect Tcl_UtfToUniCharDString() from ever reading more than "length" bytes from its input, not even in the case of invalid UTF-8. - update to latest tzdata - fix 2 failing test-cases on MacOSX --- generic/tclDate.c | 2 +- generic/tclUtf.c | 18 ++- library/tzdata/Africa/Casablanca | 280 ++++++++------------------------------- library/tzdata/Africa/El_Aaiun | 256 ++++++----------------------------- library/tzdata/Pacific/Honolulu | 5 +- tests/macOSXFCmd.test | 22 +-- 6 files changed, 127 insertions(+), 456 deletions(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index 1adcf1e..2cf20d6 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1348,7 +1348,7 @@ yyparse (info) int yychar; /* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval; +YYSTYPE yylval = {0}; /* Number of syntax errors so far. */ int yynerrs; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 656a6f0..1ef35a6 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -426,18 +426,28 @@ Tcl_UtfToUniCharDString( oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, - (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); + oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; - end = src + length; - for (p = src; p < end; ) { + p = src; + end = src + length - TCL_UTF_MAX; + while (p < end) { p += TclUtfToUniChar(p, w); w++; } + end += TCL_UTF_MAX; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, w); + } else { + *w = UCHAR(*p++); + } + w++; + } *w = '\0'; Tcl_DStringSetLength(dsPtr, - (oldLength + ((char *) w - (char *) wString))); + oldLength + ((char *) w - (char *) wString)); return wString; } diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 33ad99b..3207e59 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -2,229 +2,59 @@ set TZData(:Africa/Casablanca) { {-9223372036854775808 -1820 0 LMT} - {-1773012580 0 0 WET} - {-956361600 3600 1 WEST} - {-950490000 0 0 WET} - {-942019200 3600 1 WEST} - {-761187600 0 0 WET} - {-617241600 3600 1 WEST} - {-605149200 0 0 WET} - {-81432000 3600 1 WEST} - {-71110800 0 0 WET} - {141264000 3600 1 WEST} - {147222000 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {448243200 3600 0 CET} - {504918000 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {-1773012580 0 0 +00} + {-956361600 3600 1 +00} + {-950490000 0 0 +00} + {-942019200 3600 1 +00} + {-761187600 0 0 +00} + {-617241600 3600 1 +00} + {-605149200 0 0 +00} + {-81432000 3600 1 +00} + {-71110800 0 0 +00} + {141264000 3600 1 +00} + {147222000 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {448243200 3600 0 +01} + {504918000 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 7bdc496..e0f5e1c 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -3,217 +3,47 @@ set TZData(:Africa/El_Aaiun) { {-9223372036854775808 -3168 0 LMT} {-1136070432 -3600 0 -01} - {198291600 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {198291600 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu index 5e70598..7d03b45 100644 --- a/library/tzdata/Pacific/Honolulu +++ b/library/tzdata/Pacific/Honolulu @@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) { {-9223372036854775808 -37886 0 LMT} {-2334101314 -37800 0 HST} {-1157283000 -34200 1 HDT} - {-1155436200 -37800 0 HST} - {-880198200 -34200 1 HDT} + {-1155436200 -34200 0 HST} + {-880201800 -34200 1 HWT} + {-769395600 -34200 1 HPT} {-765376200 -37800 0 HST} {-712150200 -36000 0 HST} } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..f1758f5 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} { [catch {file attributes foo.test -hidden} msg] $msg \ [file delete -force -- foo.test] } {0 {} 0 1 {}} -test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} { +test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} { catch {file delete -force -- foo.test} close [open foo.test w] catch { @@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} { file attributes dir.test -hidden 1 } set res [list \ - [catch {glob *.test} msg] $msg \ - [catch {glob -types FOOT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types FOOTT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \ - [catch {glob -types {{macintosh type {}}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types hidden *.test} msg] $msg \ - [catch {glob -types {hidden FOOT} *.test} msg] $msg \ + [catch {lsort [glob *.test]} msg] $msg \ + [catch {lsort [glob -types FOOT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types FOOTT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types hidden *.test]} msg] $msg \ + [catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \ ] cd .. file delete -force globtest -- cgit v0.12 From 97ed5b117d97994ac272d663a4c754ab73afeace Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:36:22 +0000 Subject: (temporary) backout [0386db909a]: Enable CI builds with Travis. This enables everything else to merge-marked to 8.6. Will put it back in the next commit --- README | 185 ++++++++++++++++++++++++++++++++++++++++++++ library/tcltest/tcltest.tcl | 4 +- tests/all.tcl | 4 +- 3 files changed, 188 insertions(+), 5 deletions(-) create mode 100644 README diff --git a/README b/README new file mode 100644 index 0000000..c71d177 --- /dev/null +++ b/README @@ -0,0 +1,185 @@ +README: Tcl + This is the Tcl 8.5.19 source distribution. + http://sourceforge.net/projects/tcl/files/Tcl/ + You can get any source release of Tcl from the URL above. + +Contents +-------- + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You + +1. Introduction +--------------- +Tcl provides a powerful platform for creating integration applications that +tie together diverse applications, protocols, devices, and frameworks. +When paired with the Tk toolkit, Tcl provides the fastest and most powerful +way to create GUI applications that run on PCs, Unix, and Mac OS X. +Tcl can also be used for a variety of web-related tasks and for creating +powerful command languages for applications. + +Tcl is maintained, enhanced, and distributed freely by the Tcl community. +Source code development and tracking of bug reports and feature requests +takes place at: + + http://core.tcl.tk/ + +Tcl/Tk release and mailing list services are hosted by SourceForge: + + http://sourceforge.net/projects/tcl/ + +with the Tcl Developer Xchange hosted at: + + http://www.tcl.tk/ + +Tcl is a freely available open source package. You can do virtually +anything you like with it, such as modifying it, redistributing it, +and selling it either in whole or in part. See the file +"license.terms" for complete information. + +2. Documentation +---------------- + +Extensive documentation is available at our website. +The home page for this release, including new features, is + http://www.tcl.tk/software/tcltk/8.5.html + +Detailed release notes can be found at the file distributions page +by clicking on the relevant version. + http://sourceforge.net/projects/tcl/files/Tcl/ + +Information about Tcl itself can be found at + http://www.tcl.tk/about/ + +There have been many Tcl books on the market. Many are mentioned in the Wiki: + http://wiki.tcl.tk/_/ref?N=25206 + +To view the complete set of reference manual entries for Tcl 8.5 online, +visit the URL: + http://www.tcl.tk/man/tcl8.5/ + +2a. Unix Documentation +---------------------- + +The "doc" subdirectory in this release contains a complete set of +reference manual entries for Tcl. Files with extension ".1" are for +programs (for example, tclsh.1); files with extension ".3" are for C +library procedures; and files with extension ".n" describe Tcl +commands. The file "doc/Tcl.n" gives a quick summary of the Tcl +language syntax. To print any of the man pages on Unix, cd to the +"doc" directory and invoke your favorite variant of troff using the +normal -man macros, for example + + ditroff -man Tcl.n + +to print Tcl.n. If Tcl has been installed correctly and your "man" program +supports it, you should be able to access the Tcl manual entries using the +normal "man" mechanisms, such as + + man Tcl + +2b. Windows Documentation +------------------------- + +The "doc" subdirectory in this release contains a complete set of Windows +help files for Tcl. Once you install this Tcl release, a shortcut to the +Windows help Tcl documentation will appear in the "Start" menu: + + Start | Programs | Tcl | Tcl Help + +3. Compiling and installing Tcl +------------------------------- + +There are brief notes in the unix/README, win/README, and macosx/README about +compiling on these different platforms. There is additional information +about building Tcl from sources at + + http://www.tcl.tk/doc/howto/compile.html + +4. Development tools +--------------------------- + +ActiveState produces a high quality set of commercial quality development +tools that is available to accelerate your Tcl application development. +Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, +static code checker, single-file wrapping utility, bytecode compiler and +more. More information can be found at + + http://www.ActiveState.com/Tcl + +5. Tcl newsgroup +---------------- + +There is a USENET news group, "comp.lang.tcl", intended for the exchange of +information about Tcl, Tk, and related applications. The newsgroup is a +great place to ask general information questions. For bug reports, please +see the "Support and bug fixes" section below. + +6. Tcl'ers Wiki +--------------- + +A Wiki-based open community site covering all aspects of Tcl/Tk is at: + + http://wiki.tcl.tk/ + +It is dedicated to the Tcl programming language and its extensions. A +wealth of useful information can be found there. It contains code +snippets, references to papers, books, and FAQs, as well as pointers to +development tools, extensions, and applications. You can also recommend +additional URLs by editing the wiki yourself. + +7. Mailing lists +---------------- + +Several mailing lists are hosted at SourceForge to discuss development or +use issues (like Macintosh and Windows topics). For more information and +to subscribe, visit: + + http://sourceforge.net/projects/tcl/ + +and go to the Mailing Lists page. + +8. Support and Training +------------------------ + +We are very interested in receiving bug reports, patches, and suggestions +for improvements. We prefer that you send this information to us as +tickets entered into our tracker at: + + http://core.tcl.tk/tcl/reportlist + +We will log and follow-up on each bug, although we cannot promise a +specific turn-around time. Enhancements may take longer and may not happen +at all unless there is widespread support for them (we're trying to +slow the rate at which Tcl/Tk turns into a kitchen sink). It's very +difficult to make incompatible changes to Tcl/Tk at this point, due to +the size of the installed base. + +The Tcl community is too large for us to provide much individual support +for users. If you need help we suggest that you post questions to +comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric +questions for which no one else is likely to know the answer. In addition, +see the following Web site for links to other organizations that offer +Tcl/Tk training: + + http://wiki.tcl.tk/training + +9. Tracking Development +----------------------- + +Tcl is developed in public. To keep an eye on how Tcl is changing, see + http://core.tcl.tk/ + +10. Thank You +------------- + +We'd like to express our thanks to the Tcl community for all the +helpful suggestions, bug reports, and patches we have received. +Tcl/Tk has improved vastly and will continue to do so with your help. diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f69ffd2..936acaa 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2700,7 +2700,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# Whether there were any failures. +# None. # # Side effects: # None. @@ -2846,7 +2846,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [info exists testFileFailures] + return } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index f3463c6..d01a54d 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,6 +14,4 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] -unset -nocomplain env(ERROR_ON_FAILURES) -if {[runAllTests] && $ErrorOnFailures} {exit 1} +runAllTests -- cgit v0.12 From 52c009322f08d5c54ee93e67f439d8e06399a3a1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:52:25 +0000 Subject: put back Travis CI build. All merge-marks of previous commit change done. --- README | 185 -------------------------------------------- library/tcltest/tcltest.tcl | 4 +- tests/all.tcl | 4 +- 3 files changed, 5 insertions(+), 188 deletions(-) delete mode 100644 README diff --git a/README b/README deleted file mode 100644 index c71d177..0000000 --- a/README +++ /dev/null @@ -1,185 +0,0 @@ -README: Tcl - This is the Tcl 8.5.19 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tcl from the URL above. - -Contents --------- - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You - -1. Introduction ---------------- -Tcl provides a powerful platform for creating integration applications that -tie together diverse applications, protocols, devices, and frameworks. -When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. -Tcl can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl.tk/ - -Tcl/Tk release and mailing list services are hosted by SourceForge: - - http://sourceforge.net/projects/tcl/ - -with the Tcl Developer Xchange hosted at: - - http://www.tcl.tk/ - -Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. Documentation ----------------- - -Extensive documentation is available at our website. -The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.5.html - -Detailed release notes can be found at the file distributions page -by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/Tcl/ - -Information about Tcl itself can be found at - http://www.tcl.tk/about/ - -There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 - -To view the complete set of reference manual entries for Tcl 8.5 online, -visit the URL: - http://www.tcl.tk/man/tcl8.5/ - -2a. Unix Documentation ----------------------- - -The "doc" subdirectory in this release contains a complete set of -reference manual entries for Tcl. Files with extension ".1" are for -programs (for example, tclsh.1); files with extension ".3" are for C -library procedures; and files with extension ".n" describe Tcl -commands. The file "doc/Tcl.n" gives a quick summary of the Tcl -language syntax. To print any of the man pages on Unix, cd to the -"doc" directory and invoke your favorite variant of troff using the -normal -man macros, for example - - ditroff -man Tcl.n - -to print Tcl.n. If Tcl has been installed correctly and your "man" program -supports it, you should be able to access the Tcl manual entries using the -normal "man" mechanisms, such as - - man Tcl - -2b. Windows Documentation -------------------------- - -The "doc" subdirectory in this release contains a complete set of Windows -help files for Tcl. Once you install this Tcl release, a shortcut to the -Windows help Tcl documentation will appear in the "Start" menu: - - Start | Programs | Tcl | Tcl Help - -3. Compiling and installing Tcl -------------------------------- - -There are brief notes in the unix/README, win/README, and macosx/README about -compiling on these different platforms. There is additional information -about building Tcl from sources at - - http://www.tcl.tk/doc/howto/compile.html - -4. Development tools ---------------------------- - -ActiveState produces a high quality set of commercial quality development -tools that is available to accelerate your Tcl application development. -Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, -static code checker, single-file wrapping utility, bytecode compiler and -more. More information can be found at - - http://www.ActiveState.com/Tcl - -5. Tcl newsgroup ----------------- - -There is a USENET news group, "comp.lang.tcl", intended for the exchange of -information about Tcl, Tk, and related applications. The newsgroup is a -great place to ask general information questions. For bug reports, please -see the "Support and bug fixes" section below. - -6. Tcl'ers Wiki ---------------- - -A Wiki-based open community site covering all aspects of Tcl/Tk is at: - - http://wiki.tcl.tk/ - -It is dedicated to the Tcl programming language and its extensions. A -wealth of useful information can be found there. It contains code -snippets, references to papers, books, and FAQs, as well as pointers to -development tools, extensions, and applications. You can also recommend -additional URLs by editing the wiki yourself. - -7. Mailing lists ----------------- - -Several mailing lists are hosted at SourceForge to discuss development or -use issues (like Macintosh and Windows topics). For more information and -to subscribe, visit: - - http://sourceforge.net/projects/tcl/ - -and go to the Mailing Lists page. - -8. Support and Training ------------------------- - -We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us as -tickets entered into our tracker at: - - http://core.tcl.tk/tcl/reportlist - -We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements may take longer and may not happen -at all unless there is widespread support for them (we're trying to -slow the rate at which Tcl/Tk turns into a kitchen sink). It's very -difficult to make incompatible changes to Tcl/Tk at this point, due to -the size of the installed base. - -The Tcl community is too large for us to provide much individual support -for users. If you need help we suggest that you post questions to -comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric -questions for which no one else is likely to know the answer. In addition, -see the following Web site for links to other organizations that offer -Tcl/Tk training: - - http://wiki.tcl.tk/training - -9. Tracking Development ------------------------ - -Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ - -10. Thank You -------------- - -We'd like to express our thanks to the Tcl community for all the -helpful suggestions, bug reports, and patches we have received. -Tcl/Tk has improved vastly and will continue to do so with your help. diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 936acaa..f69ffd2 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2700,7 +2700,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2846,7 +2846,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index d01a54d..f3463c6 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,4 +14,6 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} -- cgit v0.12 From 96b9e6e871228c0a269c0b3310b987186e1a89c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 28 Oct 2018 10:04:08 +0000 Subject: Missing -DUNICODE in makefile.vc --- win/makefile.vc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 95a34d7..cc340a8 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -893,9 +893,9 @@ $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c !if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $? !else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $? !endif -- cgit v0.12 From b3291aebaa8427939c47a1cddcbf8091e0b795ec Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 13:36:10 +0000 Subject: [TIP 525] Revise [tcltest::runAllTests] to return indicator of any failure. --- library/tcltest/tcltest.tcl | 4 ++-- tests/all.tcl | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c90d726..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2741,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2887,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index e14bd9c..89a4f1a 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -22,5 +22,7 @@ if {[singleProcess]} { interp debug {} -frame 1 } -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} proc exit args {} -- cgit v0.12 From 2f4c1aecdb5225114428f32eaaf44973983ca89b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 14:00:48 +0000 Subject: [TIP 525] Backport package tcltest 2.5 --- doc/tcltest.n | 569 +++++++++++++++++++++++++++---------------- library/tcltest/pkgIndex.tcl | 4 +- library/tcltest/tcltest.tcl | 127 ++++++---- tests/tcltest.test | 56 +++-- unix/Makefile.in | 4 +- win/Makefile.in | 4 +- win/makefile.bc | 8 +- 7 files changed, 483 insertions(+), 289 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 399a673..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -7,8 +7,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +'\" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,52 +16,52 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest ?2.3?\fR -.sp -\fBtcltest::test \fIname description ?option value ...?\fR -\fBtcltest::test \fIname description ?constraints? body result\fR -.sp +\fBpackage require tcltest\fR ?\fB2.5\fR? + +\fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? +\fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR + \fBtcltest::loadTestedCommands\fR -\fBtcltest::makeDirectory \fIname ?directory?\fR -\fBtcltest::removeDirectory \fIname ?directory?\fR -\fBtcltest::makeFile \fIcontents name ?directory?\fR -\fBtcltest::removeFile \fIname ?directory?\fR -\fBtcltest::viewFile \fIname ?directory?\fR -\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR +\fBtcltest::makeDirectory \fIname\fR ?\fIdirectory\fR? +\fBtcltest::removeDirectory \fIname\fR ?\fIdirectory\fR? +\fBtcltest::makeFile \fIcontents name\fR ?\fIdirectory\fR? +\fBtcltest::removeFile \fIname\fR ?\fIdirectory\fR? +\fBtcltest::viewFile \fIname\fR ?\fIdirectory\fR? +\fBtcltest::cleanupTests \fR?\fIrunningMultipleTests\fR? \fBtcltest::runAllTests\fR -.sp + \fBtcltest::configure\fR -\fBtcltest::configure \fIoption\fR -\fBtcltest::configure \fIoption value ?option value ...?\fR +\fBtcltest::configure \fI\-option\fR +\fBtcltest::configure \fI\-option value\fR ?\fI\-option value ...\fR? \fBtcltest::customMatch \fImode command\fR -\fBtcltest::testConstraint \fIconstraint ?value?\fR -\fBtcltest::outputChannel \fI?channelID?\fR -\fBtcltest::errorChannel \fI?channelID?\fR -\fBtcltest::interpreter \fI?interp?\fR -.sp -\fBtcltest::debug \fI?level?\fR -\fBtcltest::errorFile \fI?filename?\fR -\fBtcltest::limitConstraints \fI?boolean?\fR -\fBtcltest::loadFile \fI?filename?\fR -\fBtcltest::loadScript \fI?script?\fR -\fBtcltest::match \fI?patternList?\fR -\fBtcltest::matchDirectories \fI?patternList?\fR -\fBtcltest::matchFiles \fI?patternList?\fR -\fBtcltest::outputFile \fI?filename?\fR -\fBtcltest::preserveCore \fI?level?\fR -\fBtcltest::singleProcess \fI?boolean?\fR -\fBtcltest::skip \fI?patternList?\fR -\fBtcltest::skipDirectories \fI?patternList?\fR -\fBtcltest::skipFiles \fI?patternList?\fR -\fBtcltest::temporaryDirectory \fI?directory?\fR -\fBtcltest::testsDirectory \fI?directory?\fR -\fBtcltest::verbose \fI?level?\fR -.sp +\fBtcltest::testConstraint \fIconstraint\fR ?\fIvalue\fR? +\fBtcltest::outputChannel \fR?\fIchannelID\fR? +\fBtcltest::errorChannel \fR?\fIchannelID\fR? +\fBtcltest::interpreter \fR?\fIinterp\fR? + +\fBtcltest::debug \fR?\fIlevel\fR? +\fBtcltest::errorFile \fR?\fIfilename\fR? +\fBtcltest::limitConstraints \fR?\fIboolean\fR? +\fBtcltest::loadFile \fR?\fIfilename\fR? +\fBtcltest::loadScript \fR?\fIscript\fR? +\fBtcltest::match \fR?\fIpatternList\fR? +\fBtcltest::matchDirectories \fR?\fIpatternList\fR? +\fBtcltest::matchFiles \fR?\fIpatternList\fR? +\fBtcltest::outputFile \fR?\fIfilename\fR? +\fBtcltest::preserveCore \fR?\fIlevel\fR? +\fBtcltest::singleProcess \fR?\fIboolean\fR? +\fBtcltest::skip \fR?\fIpatternList\fR? +\fBtcltest::skipDirectories \fR?\fIpatternList\fR? +\fBtcltest::skipFiles \fR?\fIpatternList\fR? +\fBtcltest::temporaryDirectory \fR?\fIdirectory\fR? +\fBtcltest::testsDirectory \fR?\fIdirectory\fR? +\fBtcltest::verbose \fR?\fIlevel\fR? + \fBtcltest::test \fIname description optionList\fR \fBtcltest::bytestring \fIstring\fR \fBtcltest::normalizeMsg \fImsg\fR \fBtcltest::normalizePath \fIpathVar\fR -\fBtcltest::workingDirectory \fI?dir?\fR +\fBtcltest::workingDirectory \fR?\fIdir\fR? .fi .BE .SH DESCRIPTION @@ -90,7 +90,8 @@ of how to use the commands of \fBtcltest\fR to produce test suites for your Tcl-enabled code. .SH COMMANDS .TP -\fBtest\fR \fIname description ?option value ...?\fR +\fBtest\fR \fIname description\fR ?\fI\-option value ...\fR? +. Defines and possibly runs a test with the name \fIname\fR and description \fIdescription\fR. The name and description of a test are used in messages reported by \fBtest\fR during the @@ -103,7 +104,8 @@ See \fBTESTS\fR below for a complete description of the valid options and how they define a test. The \fBtest\fR command returns an empty string. .TP -\fBtest\fR \fIname description ?constraints? body result\fR +\fBtest\fR \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR +. This form of \fBtest\fR is provided to support test suites written for version 1 of the \fBtcltest\fR package, and also a simpler interface for a common usage. It is the same as @@ -115,14 +117,16 @@ all \fIoption\fRs begin with .QW \- . .TP \fBloadTestedCommands\fR -Evaluates in the caller's context the script specified by +. +Evaluates in the caller's context the script specified by \fBconfigure \-load\fR or \fBconfigure \-loadfile\fR. Returns the result of that script evaluation, including any error raised by the script. Use this command and the related configuration options to provide the commands to be tested to the interpreter running the test suite. .TP -\fBmakeFile\fR \fIcontents name ?directory?\fR +\fBmakeFile\fR \fIcontents name\fR ?\fIdirectory\fR? +. Creates a file named \fIname\fR relative to directory \fIdirectory\fR and write \fIcontents\fR to that file using the encoding \fBencoding system\fR. @@ -137,14 +141,16 @@ of \fBcleanupTests\fR, unless it is removed by Returns the full path of the file created. Use this command to create any text file required by a test with contents as needed. .TP -\fBremoveFile\fR \fIname ?directory?\fR +\fBremoveFile\fR \fIname\fR ?\fIdirectory\fR? +. Forces the file referenced by \fIname\fR to be removed. This file name should be relative to \fIdirectory\fR. The default value of \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns an empty string. Use this command to delete files created by \fBmakeFile\fR. .TP -\fBmakeDirectory\fR \fIname ?directory?\fR +\fBmakeDirectory\fR \fIname\fR ?\fIdirectory\fR? +. Creates a directory named \fIname\fR relative to directory \fIdirectory\fR. The directory will be removed by the next evaluation of \fBcleanupTests\fR, unless it is removed by \fBremoveDirectory\fR first. @@ -153,7 +159,8 @@ The default value of \fIdirectory\fR is the directory Returns the full path of the directory created. Use this command to create any directories that are required to exist by a test. .TP -\fBremoveDirectory\fR \fIname ?directory?\fR +\fBremoveDirectory\fR \fIname\fR ?\fIdirectory\fR? +. Forces the directory referenced by \fIname\fR to be removed. This directory should be relative to \fIdirectory\fR. The default value of \fIdirectory\fR is the directory @@ -161,7 +168,8 @@ The default value of \fIdirectory\fR is the directory Returns an empty string. Use this command to delete any directories created by \fBmakeDirectory\fR. .TP -\fBviewFile\fR \fIfile ?directory?\fR +\fBviewFile\fR \fIfile\fR ?\fIdirectory\fR? +. Returns the contents of \fIfile\fR, except for any final newline, just as \fBread \-nonewline\fR would return. This file name should be relative to \fIdirectory\fR. @@ -174,6 +182,7 @@ the system encoding, so its usefulness is limited to text files. .TP \fBcleanupTests\fR +. Intended to clean up and summarize after several tests have been run. Typically called once per test file, at the end of the file after all tests have been completed. For best effectiveness, be @@ -188,28 +197,32 @@ in the directory \fBconfigure \-tmpdir\fR created since the last \fBcleanupTests\fR, but not created by \fBmakeFile\fR or \fBmakeDirectory\fR are printed to \fBoutputChannel\fR. This command also restores the original -shell environment, as described by the \fB::env\fR +shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR +. This is a master command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. -.SH "CONFIGURATION COMMANDS" +.SS "CONFIGURATION COMMANDS" .TP \fBconfigure\fR +. Returns the list of configurable options supported by \fBtcltest\fR. See \fBCONFIGURABLE OPTIONS\fR below for the full list of options, their valid values, and their effect on \fBtcltest\fR operations. .TP \fBconfigure \fIoption\fR +. Returns the current value of the supported configurable option \fIoption\fR. Raises an error if \fIoption\fR is not a supported configurable option. .TP -\fBconfigure \fIoption value ?option value ...?\fR +\fBconfigure \fIoption value\fR ?\fI\-option value ...\fR? +. Sets the value of each configurable option \fIoption\fR to the corresponding value \fIvalue\fR, in order. Raises an error if an \fIoption\fR is not a supported configurable option, or if @@ -220,13 +233,14 @@ arguments are not processed. .RS .PP If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when -the \fBtcltest\fR package is loaded (by \fBpackage require tcltest\fR) +the \fBtcltest\fR package is loaded (by \fBpackage require\fR \fBtcltest\fR) then its value is taken as a list of arguments to pass to \fBconfigure\fR. This allows the default values of the configuration options to be set by the environment. .RE .TP \fBcustomMatch \fImode script\fR +. Registers \fImode\fR as a new legal value of the \fB\-match\fR option to \fBtest\fR. When the \fB\-match \fImode\fR option is passed to \fBtest\fR, the script \fIscript\fR will be evaluated @@ -239,81 +253,119 @@ The completed script is expected to return a boolean value indicating whether or not the results match. The built-in matching modes of \fBtest\fR are \fBexact\fR, \fBglob\fR, and \fBregexp\fR. .TP -\fBtestConstraint \fIconstraint ?boolean?\fR +\fBtestConstraint \fIconstraint\fR ?\fIboolean\fR? +. Sets or returns the boolean value associated with the named \fIconstraint\fR. See \fBTEST CONSTRAINTS\fR below for more information. .TP -\fBinterpreter\fR \fI?executableName?\fR +\fBinterpreter\fR ?\fIexecutableName\fR? +. Sets or returns the name of the executable to be \fBexec\fRed by \fBrunAllTests\fR to run each test file when \fBconfigure \-singleproc\fR is false. The default value for \fBinterpreter\fR is the name of the currently running program as returned by \fBinfo nameofexecutable\fR. .TP -\fBoutputChannel\fR \fI?channelID?\fR -Sets or returns the output channel ID. This defaults to stdout. +\fBoutputChannel\fR ?\fIchannelID\fR? +. +Sets or returns the output channel ID. This defaults to \fBstdout\fR. Any test that prints test related output should send that output to \fBoutputChannel\fR rather than letting -that output default to stdout. +that output default to \fBstdout\fR. .TP -\fBerrorChannel\fR \fI?channelID?\fR -Sets or returns the error channel ID. This defaults to stderr. +\fBerrorChannel\fR ?\fIchannelID\fR? +. +Sets or returns the error channel ID. This defaults to \fBstderr\fR. Any test that prints error messages should send that output to \fBerrorChannel\fR rather than printing -directly to stderr. -.SH "SHORTCUT COMMANDS" -.TP -\fBdebug \fI?level?\fR -Same as \fBconfigure \-debug \fI?level?\fR. -.TP -\fBerrorFile \fI?filename?\fR -Same as \fBconfigure \-errfile \fI?filename?\fR. -.TP -\fBlimitConstraints \fI?boolean?\fR -Same as \fBconfigure \-limitconstraints \fI?boolean?\fR. -.TP -\fBloadFile \fI?filename?\fR -Same as \fBconfigure \-loadfile \fI?filename?\fR. -.TP -\fBloadScript \fI?script?\fR -Same as \fBconfigure \-load \fI?script?\fR. -.TP -\fBmatch \fI?patternList?\fR -Same as \fBconfigure \-match \fI?patternList?\fR. -.TP -\fBmatchDirectories \fI?patternList?\fR -Same as \fBconfigure \-relateddir \fI?patternList?\fR. -.TP -\fBmatchFiles \fI?patternList?\fR -Same as \fBconfigure \-file \fI?patternList?\fR. -.TP -\fBoutputFile \fI?filename?\fR -Same as \fBconfigure \-outfile \fI?filename?\fR. -.TP -\fBpreserveCore \fI?level?\fR -Same as \fBconfigure \-preservecore \fI?level?\fR. -.TP -\fBsingleProcess \fI?boolean?\fR -Same as \fBconfigure \-singleproc \fI?boolean?\fR. -.TP -\fBskip \fI?patternList?\fR -Same as \fBconfigure \-skip \fI?patternList?\fR. -.TP -\fBskipDirectories \fI?patternList?\fR -Same as \fBconfigure \-asidefromdir \fI?patternList?\fR. -.TP -\fBskipFiles \fI?patternList?\fR -Same as \fBconfigure \-notfile \fI?patternList?\fR. -.TP -\fBtemporaryDirectory \fI?directory?\fR -Same as \fBconfigure \-tmpdir \fI?directory?\fR. -.TP -\fBtestsDirectory \fI?directory?\fR -Same as \fBconfigure \-testdir \fI?directory?\fR. -.TP -\fBverbose \fI?level?\fR -Same as \fBconfigure \-verbose \fI?level?\fR. -.SH "OTHER COMMANDS" +directly to \fBstderr\fR. +.SS "SHORTCUT CONFIGURATION COMMANDS" +.TP +\fBdebug\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-debug\fR ?\fIlevel\fR?" . +.TP +\fBerrorFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-errfile\fR ?\fIfilename\fR?" . +.TP +\fBlimitConstraints\fR ?\fIboolean\fR? +. +Same as +.QW "\fBconfigure \-limitconstraints\fR ?\fIboolean\fR?" . +.TP +\fBloadFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-loadfile\fR ?\fIfilename\fR?" . +.TP +\fBloadScript\fR ?\fIscript\fR? +. +Same as +.QW "\fBconfigure \-load\fR ?\fIscript\fR?" . +.TP +\fBmatch\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-match\fR ?\fIpatternList\fR?" . +.TP +\fBmatchDirectories\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-relateddir\fR ?\fIpatternList\fR?" . +.TP +\fBmatchFiles\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-file\fR ?\fIpatternList\fR?" . +.TP +\fBoutputFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-outfile\fR ?\fIfilename\fR?" . +.TP +\fBpreserveCore\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-preservecore\fR ?\fIlevel\fR?" . +.TP +\fBsingleProcess\fR ?\fIboolean\fR? +. +Same as +.QW "\fBconfigure \-singleproc\fR ?\fIboolean\fR?" . +.TP +\fBskip\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-skip\fR ?\fIpatternList\fR?" . +.TP +\fBskipDirectories\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-asidefromdir\fR ?\fIpatternList\fR?" . +.TP +\fBskipFiles\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-notfile\fR ?\fIpatternList\fR?" . +.TP +\fBtemporaryDirectory\fR ?\fIdirectory\fR? +. +Same as +.QW "\fBconfigure \-tmpdir\fR ?\fIdirectory\fR?" . +.TP +\fBtestsDirectory\fR ?\fIdirectory\fR? +. +Same as +.QW "\fBconfigure \-testdir\fR ?\fIdirectory\fR?" . +.TP +\fBverbose\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-verbose\fR ?\fIlevel\fR?" . +.SS "OTHER COMMANDS" .PP The remaining commands provided by \fBtcltest\fR have better alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They @@ -321,6 +373,7 @@ are retained to support existing test suites, but should be avoided in new code. .TP \fBtest\fR \fIname description optionList\fR +. This form of \fBtest\fR was provided to enable passing many options spanning several lines to \fBtest\fR as a single argument quoted by braces, rather than needing to backslash quote @@ -344,13 +397,15 @@ the source code of \fBtcltest\fR if you want to know the substitution details, or just enclose the third through last argument to \fBtest\fR in braces and hope for the best. .TP -\fBworkingDirectory\fR \fI?directoryName?\fR +\fBworkingDirectory\fR ?\fIdirectoryName\fR? +. Sets or returns the current working directory when the test suite is running. The default value for workingDirectory is the directory in which the test suite was launched. The Tcl commands \fBcd\fR and \fBpwd\fR are sufficient replacements. .TP -\fBnormalizeMsg\fR \fImsg\fR +\fBnormalizeMsg \fImsg\fR +. Returns the result of removing the .QW extra newlines from \fImsg\fR, where @@ -360,20 +415,23 @@ processing commands to modify strings as you wish, and \fBcustomMatch\fR allows flexible matching of actual and expected results. .TP -\fBnormalizePath\fR \fIpathVar\fR +\fBnormalizePath \fIpathVar\fR +. Resolves symlinks in a path, thus creating a path without internal redirection. It is assumed that \fIpathVar\fR is absolute. \fIpathVar\fR is modified in place. The Tcl command \fBfile normalize\fR is a sufficient replacement. .TP -\fBbytestring\fR \fIstring\fR +\fBbytestring \fIstring\fR +. Construct a string that consists of the requested sequence of bytes, as opposed to a string of properly formed UTF-8 characters using the value supplied in \fIstring\fR. This allows the tester to create denormalized or improperly formed strings to pass to C procedures that are supposed to accept strings with embedded NULL types and confirm that a string result has a certain pattern of bytes. This is -exactly equivalent to the Tcl command \fBencoding convertfrom identity\fR. +exactly equivalent to the Tcl command \fBencoding convertfrom\fR +\fBidentity\fR. .SH TESTS .PP The \fBtest\fR command is the heart of the \fBtcltest\fR package. @@ -388,15 +446,16 @@ The valid options for \fBtest\fR are summarized: .PP .CS \fBtest\fR \fIname\fR \fIdescription\fR - ?-constraints \fIkeywordList|expression\fR? - ?-setup \fIsetupScript\fR? - ?-body \fItestScript\fR? - ?-cleanup \fIcleanupScript\fR? - ?-result \fIexpectedAnswer\fR? - ?-output \fIexpectedOutput\fR? - ?-errorOutput \fIexpectedError\fR? - ?-returnCodes \fIcodeList\fR? - ?-match \fImode\fR? + ?\fB\-constraints \fIkeywordList|expression\fR? + ?\fB\-setup \fIsetupScript\fR? + ?\fB\-body \fItestScript\fR? + ?\fB\-cleanup \fIcleanupScript\fR? + ?\fB\-result \fIexpectedAnswer\fR? + ?\fB\-output \fIexpectedOutput\fR? + ?\fB\-errorOutput \fIexpectedError\fR? + ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? + ?\fB\-match \fImode\fR? .CE .PP The \fIname\fR may be any string. It is conventional to choose @@ -428,11 +487,12 @@ test, typically test failure messages. Good \fIdescription\fR values should briefly explain the purpose of the test to users of a test suite. The name of a Tcl or C function being tested should be included in the description for regression tests. If the test case exists to reproduce -a bug, include the bug ID in the description. +a bug, include the bug ID in the description. .PP Valid attributes and associated values are: .TP -\fB\-constraints \fIkeywordList|expression\fR +\fB\-constraints \fIkeywordList\fR|\fIexpression\fR +. The optional \fB\-constraints\fR attribute can be list of one or more keywords or an expression. If the \fB\-constraints\fR value is a list of keywords, each of these keywords should be the name of a constraint @@ -449,29 +509,35 @@ should be accomplished by the \fB\-constraints\fR option, not by conditional evaluation of \fBtest\fR. In that way, the same number of tests are always reported by the test suite, though the number skipped may change based on the testing environment. -The default value is an empty list. -See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints +The default value is an empty list. +See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints and information on how to add your own constraints. .TP \fB\-setup \fIscript\fR +. The optional \fB\-setup\fR attribute indicates a \fIscript\fR that will be run before the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. .TP \fB\-body \fIscript\fR -The \fB\-body\fR attribute indicates the \fIscript\fR to run to carry out the -test. It must return a result that can be checked for correctness. -If evaluation of \fIscript\fR raises an error, the test will fail. +. +The \fB\-body\fR attribute indicates the \fIscript\fR to run to carry out the +test, which must return a result that can be checked for correctness. +If evaluation of \fIscript\fR raises an error, the test will fail +(unless the \fB\-returnCodes\fR option is used to state that an error +is expected). The default value is an empty script. .TP \fB\-cleanup \fIscript\fR +. The optional \fB\-cleanup\fR attribute indicates a \fIscript\fR that will be run after the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. .TP \fB\-match \fImode\fR +. The \fB\-match\fR attribute determines how expected answers supplied by \fB\-result\fR, \fB\-output\fR, and \fB\-errorOutput\fR are compared. Valid values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and @@ -479,27 +545,31 @@ any value registered by a prior call to \fBcustomMatch\fR. The default value is \fBexact\fR. .TP \fB\-result \fIexpectedValue\fR +. The \fB\-result\fR attribute supplies the \fIexpectedValue\fR against which the return value from script will be compared. The default value is an empty string. .TP \fB\-output \fIexpectedValue\fR +. The \fB\-output\fR attribute supplies the \fIexpectedValue\fR against which any output sent to \fBstdout\fR or \fBoutputChannel\fR during evaluation of the script(s) will be compared. Note that only output printed using -\fB::puts\fR is used for comparison. If \fB\-output\fR is not specified, -output sent to \fBstdout\fR and \fBoutputChannel\fR is not processed for -comparison. +the global \fBputs\fR command is used for comparison. If \fB\-output\fR is +not specified, output sent to \fBstdout\fR and \fBoutputChannel\fR is not +processed for comparison. .TP \fB\-errorOutput \fIexpectedValue\fR +. The \fB\-errorOutput\fR attribute supplies the \fIexpectedValue\fR against -which any output sent to \fBstderr\fR or \fBerrorChannel\fR during +which any output sent to \fBstderr\fR or \fBerrorChannel\fR during evaluation of the script(s) will be compared. Note that only output -printed using \fB::puts\fR is used for comparison. If \fB\-errorOutput\fR -is not specified, output sent to \fBstderr\fR and \fBerrorChannel\fR is -not processed for comparison. +printed using the global \fBputs\fR command is used for comparison. If +\fB\-errorOutput\fR is not specified, output sent to \fBstderr\fR and +\fBerrorChannel\fR is not processed for comparison. .TP \fB\-returnCodes \fIexpectedCodeList\fR +. The optional \fB\-returnCodes\fR attribute supplies \fIexpectedCodeList\fR, a list of return codes that may be accepted from evaluation of the \fB\-body\fR script. If evaluation of the \fB\-body\fR script returns @@ -507,7 +577,16 @@ a code not in the \fIexpectedCodeList\fR, the test fails. All return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is -.QW \fBok return\fR. +.QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and @@ -524,12 +603,12 @@ In default operation, a successful test produces no output. The output messages produced by \fBtest\fR are controlled by the \fBconfigure \-verbose\fR option as described in \fBCONFIGURABLE OPTIONS\fR below. Any output produced by the test scripts themselves should be -produced using \fB::puts\fR to \fBoutputChannel\fR or +produced using \fBputs\fR to \fBoutputChannel\fR or \fBerrorChannel\fR, so that users of the test suite may easily capture output with the \fBconfigure \-outfile\fR and \fBconfigure \-errfile\fR options, and so that the \fB\-output\fR and \fB\-errorOutput\fR attributes work properly. -.SH "TEST CONSTRAINTS" +.SS "TEST CONSTRAINTS" .PP Constraints are used to determine whether or not a test should be skipped. Each constraint has a name, which may be any string, and a boolean @@ -557,112 +636,133 @@ The following is a list of constraints pre-defined by the \fBtcltest\fR package itself: .TP \fIsingleTestInterp\fR -test can only be run if all test files are sourced into a single interpreter +. +This test can only be run if all test files are sourced into a single +interpreter. .TP \fIunix\fR -test can only be run on any Unix platform +. +This test can only be run on any Unix platform. .TP \fIwin\fR -test can only be run on any Windows platform +. +This test can only be run on any Windows platform. .TP \fInt\fR -test can only be run on any Windows NT platform -.TP -\fI95\fR -test can only be run on any Windows 95 platform -.TP -\fI98\fR -test can only be run on any Windows 98 platform +. +This test can only be run on any Windows NT platform. .TP \fImac\fR -test can only be run on any Mac platform +. +This test can only be run on any Mac platform. .TP \fIunixOrWin\fR -test can only be run on a Unix or Windows platform +. +This test can only be run on a Unix or Windows platform. .TP \fImacOrWin\fR -test can only be run on a Mac or Windows platform +. +This test can only be run on a Mac or Windows platform. .TP \fImacOrUnix\fR -test can only be run on a Mac or Unix platform +. +This test can only be run on a Mac or Unix platform. .TP \fItempNotWin\fR -test can not be run on Windows. This flag is used to temporarily -disable a test. +. +This test can not be run on Windows. This flag is used to temporarily +disable a test. .TP \fItempNotMac\fR -test can not be run on a Mac. This flag is used +. +This test can not be run on a Mac. This flag is used to temporarily disable a test. .TP \fIunixCrash\fR -test crashes if it is run on Unix. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on Unix. This flag is used to temporarily +disable a test. .TP \fIwinCrash\fR -test crashes if it is run on Windows. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on Windows. This flag is used to temporarily +disable a test. .TP \fImacCrash\fR -test crashes if it is run on a Mac. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on a Mac. This flag is used to temporarily +disable a test. .TP \fIemptyTest\fR -test is empty, and so not worth running, but it remains as a +. +This test is empty, and so not worth running, but it remains as a place-holder for a test to be written in the future. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. .TP \fIknownBug\fR -test is known to fail and the bug is not yet fixed. This constraint +. +This test is known to fail and the bug is not yet fixed. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. .TP \fInonPortable\fR -test can only be run in some known development environment. +. +This test can only be run in some known development environment. Some tests are inherently non-portable because they depend on things like word length, file system configuration, window manager, etc. This constraint has value false to cause tests to be skipped unless -the user specifies otherwise. +the user specifies otherwise. .TP \fIuserInteraction\fR -test requires interaction from the user. This constraint has +. +This test requires interaction from the user. This constraint has value false to causes tests to be skipped unless the user specifies -otherwise. +otherwise. .TP \fIinteractive\fR -test can only be run in if the interpreter is in interactive mode +. +This test can only be run in if the interpreter is in interactive mode (when the global tcl_interactive variable is set to 1). .TP \fInonBlockFiles\fR -test can only be run if platform supports setting files into -nonblocking mode +. +This test can only be run if platform supports setting files into +nonblocking mode. .TP \fIasyncPipeClose\fR -test can only be run if platform supports async flush and async close -on a pipe +. +This test can only be run if platform supports async flush and async close +on a pipe. .TP \fIunixExecs\fR -test can only be run if this machine has Unix-style commands +. +This test can only be run if this machine has Unix-style commands \fBcat\fR, \fBecho\fR, \fBsh\fR, \fBwc\fR, \fBrm\fR, \fBsleep\fR, -\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available +\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available. .TP \fIhasIsoLocale\fR -test can only be run if can switch to an ISO locale +. +This test can only be run if can switch to an ISO locale. .TP \fIroot\fR -test can only run if Unix user is root +. +This test can only run if Unix user is root. .TP \fInotRoot\fR -test can only run if Unix user is not root +. +This test can only run if Unix user is not root. .TP \fIeformat\fR -test can only run if app has a working version of sprintf with respect +. +This test can only run if app has a working version of sprintf with respect to the .QW e format of floating-point numbers. .TP \fIstdio\fR -test can only be run if \fBinterpreter\fR can be \fBopen\fRed +. +This test can only be run if \fBinterpreter\fR can be \fBopen\fRed as a pipe. .PP The alternative mode of constraint control is enabled by setting @@ -685,7 +785,7 @@ up a configuration with .PP to run exactly those tests that exercise known bugs, and discover whether any of them pass, indicating the bug had been fixed. -.SH "RUNNING ALL TESTS" +.SS "RUNNING ALL TESTS" .PP The single command \fBrunAllTests\fR is evaluated to run an entire test suite, spanning many files and directories. The configuration @@ -702,7 +802,7 @@ and sorted. Then each file will be evaluated in turn. If be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful -when testing can cause errors so severe that a process +when testing can cause errors so severe that a process terminates. Although such an error may terminate a child process evaluating one file, the master process can continue with the rest of the test suite. In multi-process operation, @@ -748,17 +848,19 @@ The \fBconfigure\fR command is used to set and query the configurable options of \fBtcltest\fR. The valid options are: .TP \fB\-singleproc \fIboolean\fR +. Controls whether or not \fBrunAllTests\fR spawns a child process for each test file. No spawning when \fIboolean\fR is true. Default value is false. .TP \fB\-debug \fIlevel\fR +. Sets the debug level to \fIlevel\fR, an integer value indicating how -much debugging information should be printed to stdout. Note that -debug messages always go to stdout, independent of the value of +much debugging information should be printed to \fBstdout\fR. Note that +debug messages always go to \fBstdout\fR, independent of the value of \fBconfigure \-outfile\fR. Default value is 0. Levels are defined as: .RS -.IP 0 +.IP 0 4 Do not display any debug information. .IP 1 Display information regarding whether a test is skipped because it @@ -769,41 +871,55 @@ print warnings about possible lack of cleanup or balance in test files. Also print warnings about any re-use of test names. .IP 2 Display the flag array parsed by the command line processor, the -contents of the ::env array, and all user-defined variables that exist -in the current namespace as they are used. +contents of the global \fBenv\fR array, and all user-defined variables +that exist in the current namespace as they are used. .IP 3 Display information regarding what individual procs in the test harness are doing. .RE .TP \fB\-verbose \fIlevel\fR +. Sets the type of output verbosity desired to \fIlevel\fR, a list of zero or more of the elements \fBbody\fR, \fBpass\fR, -\fBskip\fR, \fBstart\fR, \fBerror\fR and \fBline\fR. Default value -is \fB{body error}\fR. -Levels are defined as: +\fBskip\fR, \fBstart\fR, \fBerror\fR, \fBline\fR, \fBmsec\fR and \fBusec\fR. +Default value is +.QW "\fBbody error\fR" . +Levels are defined as: .RS -.IP "body (b)" +.IP "body (\fBb\fR)" Display the body of failed tests -.IP "pass (p)" +.IP "pass (\fBp\fR)" Print output when a test passes -.IP "skip (s)" +.IP "skip (\fBs\fR)" Print output when a test is skipped -.IP "start (t)" +.IP "start (\fBt\fR)" Print output whenever a test starts -.IP "error (e)" +.IP "error (\fBe\fR)" Print errorInfo and errorCode, if they exist, when a test return code does not match its expected return code -.IP "line (l)" +.IP "line (\fBl\fR)" Print source file line information of failed tests -.RE +.IP "msec (\fBm\fR)" +Print each test's execution time in milliseconds +.IP "usec (\fBu\fR)" +Print each test's execution time in microseconds +.PP +Note that the \fBmsec\fR and \fBusec\fR verbosity levels are provided as +indicative measures only. They do not tackle the problem of repeatibility which +should be considered in performance tests or benchmarks. To use these verbosity +levels to thoroughly track performance degradations, consider wrapping your +test bodies with \fBtime\fR commands. +.PP The single letter abbreviations noted above are also recognized so that .QW "\fBconfigure \-verbose pt\fR" is the same as .QW "\fBconfigure \-verbose {pass start}\fR" . +.RE .TP \fB\-preservecore \fIlevel\fR +. Sets the core preservation level to \fIlevel\fR. This level determines how stringent checks for core files are. Default value is 0. Levels are defined as: @@ -815,21 +931,24 @@ test files have been evaluated. .IP 1 Also check for core files at the end of each \fBtest\fR command. .IP 2 -Check for core files at all times described above, and save a +Check for core files at all times described above, and save a copy of each core file produced in \fBconfigure \-tmpdir\fR. .RE .TP \fB\-limitconstraints \fIboolean\fR +. Sets the mode by which \fBtest\fR honors constraints as described in \fBTESTS\fR above. Default value is false. .TP \fB\-constraints \fIlist\fR +. Sets all the constraints in \fIlist\fR to true. Also used in combination with \fBconfigure \-limitconstraints true\fR to control an alternative constraint mode as described in \fBTESTS\fR above. Default value is an empty list. .TP \fB\-tmpdir \fIdirectory\fR +. Sets the temporary directory to be used by \fBmakeFile\fR, \fBmakeDirectory\fR, \fBviewFile\fR, \fBremoveFile\fR, and \fBremoveDirectory\fR as the default directory where @@ -837,55 +956,66 @@ temporary files and directories created by test files should be created. Default value is \fBworkingDirectory\fR. .TP \fB\-testdir \fIdirectory\fR +. Sets the directory searched by \fBrunAllTests\fR for test files and subdirectories. Default value is \fBworkingDirectory\fR. .TP \fB\-file \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to evaluate. Default value is .QW \fB*.test\fR . .TP \fB\-notfile \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to skip. Default value is .QW \fBl.*.test\fR , so that any SCCS lock files are skipped. .TP \fB\-relateddir \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to search for an \fBall.tcl\fR file. Default value is .QW \fB*\fR . .TP \fB\-asidefromdir \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to skip when searching for an \fBall.tcl\fR file. Default value is an empty list. .TP \fB\-match \fIpatternList\fR +. Set the list of patterns used by \fBtest\fR to determine whether a test should be run. Default value is .QW \fB*\fR . .TP \fB\-skip \fIpatternList\fR +. Set the list of patterns used by \fBtest\fR to determine whether a test should be skipped. Default value is an empty list. .TP \fB\-load \fIscript\fR +. Sets a script to be evaluated by \fBloadTestedCommands\fR. Default value is an empty script. .TP \fB\-loadfile \fIfilename\fR +. Sets the filename from which to read a script to be evaluated by \fBloadTestedCommands\fR. This is an alternative to \fB\-load\fR. They cannot be used together. .TP -\fB\-outfile \fIfilename\fR +\fB\-outfile \fIfilename\fR +. Sets the file to which all output produced by tcltest should be written. A file named \fIfilename\fR will be \fBopen\fRed for writing, and the resulting channel will be set as the value of \fBoutputChannel\fR. .TP \fB\-errfile \fIfilename\fR +. Sets the file to which all error output produced by tcltest should be written. A file named \fIfilename\fR will be \fBopen\fRed for writing, and the resulting channel will be set as the value @@ -948,12 +1078,14 @@ Test with a constraint. .PP At the next higher layer of organization, several \fBtest\fR commands are gathered together into a single test file. Test files should have -names with the \fB.test\fR extension, because that is the default pattern +names with the +.QW \fB.test\fR +extension, because that is the default pattern used by \fBrunAllTests\fR to find test files. It is a good rule of thumb to have one test file for each source code file of your project. It is good practice to edit the test file and the source code file together, keeping tests synchronized with code changes. -.PP +.PP Most of the code in the test file should be the \fBtest\fR commands. Use constraints to skip tests, rather than conditional evaluation of \fBtest\fR. @@ -976,7 +1108,7 @@ guard: .PP .CS if $myRequirement { - test badConditionalTest {} { + \fBtest\fR badConditionalTest {} { #body } result } @@ -1066,7 +1198,7 @@ to continue to support existing test suites written to the older interface specifications, many of those deprecated commands and variables still work as before. For example, in many circumstances, \fBconfigure\fR will be automatically called shortly after -\fBpackage require tcltest 2.1\fR succeeds with arguments +\fBpackage require\fR \fBtcltest 2.1\fR succeeds with arguments from the variable \fB::argv\fR. This is to support test suites that depend on the old behavior that \fBtcltest\fR was automatically configured from command line arguments. New test files should not @@ -1076,12 +1208,18 @@ depend on this, but should explicitly include eval \fB::tcltest::configure\fR $::argv .CE .PP +or +.PP +.CS +\fB::tcltest::configure\fR {*}$::argv +.CE +.PP to establish a configuration from command line arguments. .SH "KNOWN ISSUES" There are two known issues related to nested evaluations of \fBtest\fR. The first issue relates to the stack level in which test scripts are executed. Tests nested within other tests may be executed at the same -stack level as the outermost test. For example, in the following code: +stack level as the outermost test. For example, in the following code: .PP .CS \fBtest\fR level-1.1 {level 1} { @@ -1093,7 +1231,7 @@ stack level as the outermost test. For example, in the following code: .CE .PP any script executed in level-2.1 may be executed at the same stack -level as the script defined for level-1.1. +level as the script defined for level-1.1. .PP In addition, while two \fBtest\fRs have been run, results will only be reported by \fBcleanupTests\fR for tests at the same level as @@ -1117,12 +1255,15 @@ and refer to tests that were run at the same test level as test level-1.1. .PP Implementation of output and error comparison in the test command -depends on usage of ::puts in your application code. Output is -intercepted by redefining the ::puts command while the defined test +depends on usage of \fBputs\fR in your application code. Output is +intercepted by redefining the global \fBputs\fR command while the defined test script is being run. Errors thrown by C procedures or printed -directly from C applications will not be caught by the test command. +directly from C applications will not be caught by the \fBtest\fR command. Therefore, usage of the \fB\-output\fR and \fB\-errorOutput\fR options to \fBtest\fR is useful only for pure Tcl applications -that use \fB::puts\fR to produce output. +that use \fBputs\fR to produce output. .SH KEYWORDS test, test harness, test suite +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 987725f..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.8 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 936acaa..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,13 +16,13 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require Tcl 8.5 ;# -verbose line uses [info frame] +package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.8 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -347,7 +347,7 @@ namespace eval tcltest { # This is very subtle and tricky, so let me try to explain. # (Hopefully this longer comment will be clear when I come # back in a few months, unlike its predecessor :) ) - # + # # The [outputChannel] command (and underlying variable) have to # be kept in sync with the [configure -outfile] configuration # option ( and underlying variable Option(-outfile) ). This is @@ -362,12 +362,12 @@ namespace eval tcltest { # configuration options to parse the command line option the first # time they are read. These traces are cancelled whenever the # program itself calls [configure]. - # + # # OK, then so to support tcltest 1 compatibility, it seems we want # to get the return from [outputFile] to trigger the read traces, # just in case. # - # BUT! A little known feature of Tcl variable traces is that + # BUT! A little known feature of Tcl variable traces is that # traces are disabled during the handling of other traces. So, # if we trigger read traces on Option(-outfile) and that triggers # command line parsing which turns around and sets an initial @@ -608,19 +608,30 @@ namespace eval tcltest { set code [catch {Configure {*}$args} msg] return -code $code $msg } - + proc AcceptVerbose { level } { set level [AcceptList $level] + set levelMap { + l list + p pass + b body + s skip + t start + e error + l line + m msec + u usec + } + set levelRegexp "^([join [dict values $levelMap] |])\$" if {[llength $level] == 1} { - if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { + if {![regexp $levelRegexp $level]} { # translate single characters abbreviations to expanded list - set level [string map {p pass b body s skip t start e error l line} \ - [split $level {}]] + set level [string map $levelMap [split $level {}]] } } set valid [list] foreach v $level { - if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { + if {[regexp $levelRegexp $v]} { lappend valid $v } } @@ -639,7 +650,7 @@ namespace eval tcltest { skipped tests if 's' is specified, the bodies of failed tests if 'b' is specified, and when tests start if 't' is specified. ErrorInfo is displayed if 'e' is specified. Source file line - information of failed tests is displayed if 'l' is specified. + information of failed tests is displayed if 'l' is specified. } AcceptVerbose verbose # Match and skip patterns default to the empty list, except for @@ -687,7 +698,7 @@ namespace eval tcltest { # some additional output regarding operations of the test harness. # The tcltest package currently implements only up to debug level 3. Option -debug 0 { - Internal debug level + Internal debug level } AcceptInteger debug proc SetSelectedConstraints args { @@ -715,7 +726,7 @@ namespace eval tcltest { } Option -limitconstraints 0 { whether to run only tests with the constraints - } AcceptBoolean limitConstraints + } AcceptBoolean limitConstraints trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] @@ -728,7 +739,7 @@ namespace eval tcltest { # Default is to run each test file in a separate process Option -singleproc 0 { whether to run all tests in one process - } AcceptBoolean singleProcess + } AcceptBoolean singleProcess proc AcceptTemporaryDirectory { directory } { set directory [AcceptAbsolutePath $directory] @@ -1243,10 +1254,6 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer interactive \ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} - # Skip slow tests (to enable slow tests add parameter `-constraints slowTest`) - - ConstraintInitializer slowTest {format 0} - # Some tests can only be run if the installation came from a CD # image instead of a web image. Some tests must be skipped if you # are running as root on Unix. Other tests can only be run if you @@ -1261,7 +1268,7 @@ proc tcltest::DefineConstraintInitializers {} { # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { - set code [expr {[catch {set f [open defs r]}] + set code [expr {[catch {set f [open defs r]}] || [catch {chan configure $f -blocking off}]}] catch {close $f} set code @@ -1275,7 +1282,7 @@ proc tcltest::DefineConstraintInitializers {} { # (Mark Diekhans). ConstraintInitializer asyncPipeClose {expr { - !([string equal unix $::tcl_platform(platform)] + !([string equal unix $::tcl_platform(platform)] && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} # Test to see if we have a broken version of sprintf with respect @@ -1834,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1875,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1885,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1894,7 +1907,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1905,7 +1918,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1937,6 +1950,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1958,7 +1975,7 @@ proc tcltest::test {name description args} { return } - # Save information about the core file. + # Save information about the core file. if {[preserveCore]} { if {[file exists [file join [workingDirectory] core]]} { set coreModTime [file mtime [file join [workingDirectory] core]] @@ -1969,13 +1986,18 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] # Only run the test body if the setup was successful if {!$setupFailure} { + # Register startup time + if {[IsVerbose msec] || [IsVerbose usec]} { + set timeStart [clock microseconds] + } + # Verbose notification of $body start if {[IsVerbose start]} { puts [outputChannel] "---- $name start" @@ -1991,7 +2013,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2000,6 +2022,11 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errorCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2043,7 +2070,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2064,7 +2091,7 @@ proc tcltest::test {name description args} { } else { set coreFailure 1 } - + if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" @@ -2080,11 +2107,21 @@ proc tcltest::test {name description args} { } } + if {[IsVerbose msec] || [IsVerbose usec]} { + set t [expr {[clock microseconds] - $timeStart}] + if {[IsVerbose usec]} { + puts [outputChannel] "++++ $name took $t μs" + } + if {[IsVerbose msec]} { + puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" + } + } + # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2104,7 +2141,7 @@ proc tcltest::test {name description args} { variable currentFailure true if {![IsVerbose body]} { set body "" - } + } puts [outputChannel] "\n" if {[IsVerbose line]} { if {![catch {set testFrame [info frame -1]}] && @@ -2125,7 +2162,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "$testFile:$testLine: error: test failed:\ $name [string trim $description]" } - } + } puts [outputChannel] "==== $name\ [string trim $description] FAILED" if {[string length $body]} { @@ -2137,7 +2174,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2149,6 +2186,10 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } @@ -2164,7 +2205,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2190,7 +2231,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { @@ -2281,7 +2322,7 @@ proc tcltest::Skipped {name constraints} { } } } - + if {!$doTest} { if {[IsVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" @@ -2687,7 +2728,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { DebugPuts 1 "No test directories remain after applying match\ and skip patterns!" } - return $matchDirs + return [lsort $matchDirs] } # tcltest::runAllTests -- @@ -2700,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2838,15 +2879,15 @@ proc tcltest::runAllTests { {shell ""} } { set dir [file tail $directory] puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - + uplevel 1 [list ::source [file join $directory all.tcl]] - + set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### @@ -3023,7 +3064,7 @@ proc tcltest::removeFile {name {directory ""}} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } - } + } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" @@ -3094,7 +3135,7 @@ proc tcltest::removeDirectory {name {directory ""}} { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } - } + } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" @@ -3289,7 +3330,7 @@ proc tcltest::threadReap {} { testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { - + # Thread extension thread::errorproc ThreadNullError diff --git a/tests/tcltest.test b/tests/tcltest.test index 028d4fa..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -142,7 +143,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose 't'] list $result $msg @@ -152,7 +153,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose start] list $result $msg @@ -169,7 +170,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -217,7 +218,7 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [slave msg test.tcl -skip a* -verbose 'ps'] @@ -299,8 +300,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} @@ -311,7 +312,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ -result [lsort { 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles - nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp slowTest socket + nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly }] @@ -348,7 +349,7 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] @@ -367,7 +368,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { slave msg $printerror -errfile a.tmp @@ -413,7 +414,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -449,7 +450,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -719,7 +720,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } @@ -760,7 +761,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -773,7 +774,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -907,7 +908,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -919,6 +922,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -1148,7 +1156,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { interp delete slave2 interp delete slave1 if {$oldoptions eq "none"} { - unset ::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1199,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1262,7 +1270,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1292,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1312,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1426,7 +1434,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1449,7 +1457,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1826,9 +1834,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/Makefile.in b/unix/Makefile.in index 50f4bb3..7e8e4a3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -785,8 +785,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.8 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.8.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 7fc415d..f197190 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -659,8 +659,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.8 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; diff --git a/win/makefile.bc b/win/makefile.bc index 577c865..8f337e3 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -432,10 +432,10 @@ install-libraries: -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" - @echo Installing tcltest2.3 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" + @echo Installing tcltest2.5 + -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.5" + -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5" + -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5" @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -- cgit v0.12 From ce6023fade965eb75c891c4d455cd95c25a169d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 14:38:24 +0000 Subject: [TIP 525] Backport package tcltest 2.5 --- doc/tcltest.n | 14 ++++++++++++-- library/tcltest/pkgIndex.tcl | 4 ++-- library/tcltest/tcltest.tcl | 45 +++++++++++++++++++++++++++++++------------- tests/tcltest.test | 10 +++++----- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 55 insertions(+), 26 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 05c1922..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,7 +16,7 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest\fR ?\fB2.3\fR? +\fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR @@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized: ?\fB\-output \fIexpectedOutput\fR? ?\fB\-errorOutput \fIexpectedError\fR? ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? ?\fB\-match \fImode\fR? .CE .PP @@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index c9d3759..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f1b6082..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1892,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1901,7 +1907,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1912,7 +1918,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1944,6 +1950,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1976,7 +1986,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] @@ -2003,7 +2013,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2012,6 +2022,11 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errorCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2055,7 +2070,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2106,7 +2121,7 @@ proc tcltest::test {name description args} { variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2159,7 +2174,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2171,6 +2186,10 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } @@ -2186,7 +2205,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2212,7 +2231,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { @@ -2722,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2868,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/tcltest.test b/tests/tcltest.test index 0bcf342..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -908,7 +908,7 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { - -constraints notValgrind + -constraints notValgrind -setup { #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest @@ -926,7 +926,7 @@ test tcltest-13.1 {interpreter} { # constraint, which involves a call to [exec] that might fail after # "fork" and before "exec", in which case the forked process will not # have a chance to clean itself up before exiting, which causes - # valgrind to issue numerous "still reachable" reports. + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ diff --git a/unix/Makefile.in b/unix/Makefile.in index a2621a3..66114ba 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -851,8 +851,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 8ce57f2..9d955cd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -660,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.1.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12